*COMDECK BLOADS  SEGMENTED LOAD GENERATION. 
          COMMENT LOADER - GENERATE SEGMENT LOAD. 
          ORG    LOCG+1 
          QUAL   LOADS
  
**        ++++++++++++++++++++++++++++
*         + SEGMENT LOAD GENERATION. +
*         ++++++++++++++++++++++++++++
* 
*              SEGMENT GENERATION IS BROKEN UP INTO THREE PARTS. THE
*         FIRST PART IS INITIALIZATION WHICH READS THE *SEGLOAD*
*         DIRECTIVES AND LISTS THEM IF REQUESTED.  ONCE THE DIRECTIVES
*         HAVE BEEN READ WITHOUT FATAL ERRORS, A TREE DIAGRAM WILL
*         BE GENERATED. 
* 
*              PASS 1 USES THE INITIALIZATION AREA AS A BUFFER TO COPY
*         PROGRAMS READ FROM LOAD FILES AND LIBRARIES.  ONCE ALL LOADER 
*         DIRECTIVES EXCEPT *NOGO* OR *EXECUTE* HAVE BEEN PROCESSED 
*         AND EXTERNALS SATISFIED, THE PROCESS OF ASSIGNING PROGRAMS
*         AND BLOCKS TO SEGMENTS BEGINS.  AFTER THE COMPLETION OF THE 
*         ASSIGNMENT PROCESS THE MANAGED TABLES *TLNK*, *TBLK* AND
*         *TCEL* ARE CREATED AND THE BINARY FILE  IS INITIALIZED. 
* 
*              PASS 2 SCANS THROUGH *TBLK* LOADING BLOCKS AND PROGRAMS
*         INTO OVERLAYS AND WRITES THESE OVERLAYS ONTO THE BINARY 
*         FILE.  THE BINARY FILE IS COMPLETED BY ADDING THE ECS IMAGE 
*         IF ANY AND THE TABLE *TCEL* FOR *SEGRES* TO USE.  WE NOW
*         CALL THE LOAD COMPLETION ROUTINE TO GENERATE THE MAP AND
*         CALL *SEGRES* IF NECESSARY. 
* 
*              TERMS WHICH ARE USED THROUGHOUT A SEGMENT LOAD ARE 
*         DEFINED HERE. 
* 
*         SEGMENT INDEX = INDEX OF THE SEGMENT ENTRY IN MANAGED TABLE 
*                *TCEL* OR *TSEG*.  BEFORE *TCEL* IS CREATED THE INDEX
*                REFERENCES THE TABLE *TSEG*. 
*         SEGMENT ORDINAL = SEGMENT INDEX DIVIDED BY TWO.  THIS IS USED 
*                SO THAT THE SEGMENT CAN BE IDENTIFIED IN A 12 BIT
*                FIELD (0,1,...,4095).
*         SEGMENT NUMBER = SAME AS SEGMENT ORDINAL. 
          TITLE  SEGMENT GENERATION - PASS 2. 
          SPACE  4,8
**        SYMBOL DEFINITIONS FOR PASS 2.
  
  
 BC       CON    7L          BLANK COMMON NAME IN *TSEG*
 CS       CON    6           CURRENT SEGMENT INDEX IN *TBLK*
 DA       CON    0           DISK ADDRESS (PRU) OF CURRENT WRITE
 DE       CON    0           INDEX INTO *TPGM* FOR NEXT DELINK ENTRY
 EA       CON    0           DISK ADDRESS OF ECS IMAGE ON BINARY FILE 
 UD       CON    2L'?        UNIQUE NAME PREFIX 
 UN       CON    0           INDEX OF LAST UNIQUE BLOCK NAME USED 
 Z1       DATA   0LZZZZZ31   SEGMENT LOAD SCRATCH FILE
 Z2       DATA   0LZZZZZ32   ALTERNATE FILE FOR SEGMENT OVERLAYS
          SPACE  4,8
 DB       IFTEST NE,IP.LDBG,0 
**        SEGMENT GENERATION DEBUG MESSAGES.
  
  
 DBG      DATA   10HNG SEGMENT
          DATA   10H
 DBG1     DATA   C*  READING DIRECTIVES.* 
 DBG2     DATA   C*  REARRANGING SEGMENTS.* 
 DBG3     DATA   C*  GENERATING TREE DIAGRAM.*
 DBG4     DATA   C*  READING ....... FROM .......*
 DBG5     DATA   C*  ASSIGN PROGS TO SEGMENTS.* 
 DBG6     DATA   C*  COMPUTING DELINK LENGTHS.* 
 DBG7     DATA   C*  CREATING BLOCK TABLE.* 
 DBG8     DATA   C*  REWRITING ECS IMAGE.*
 DB       ENDIF 
          SPACE  4,8
**        PASS 2 PROCESSING.
* 
*              MOST OF THE WORK FOR SEGMENT LOADING HAS ALREADY 
*         BEEN DONE.  WE SIMPLY LOAD THE PROGRAMS, WRITE THE *TPGM* 
*         IMAGE ONTO THE BINARY FILE, REWRITE THE ECS IMAGE AND 
*         COMPLETE THE BINARY FILE BEFORE TRANSFERRING CONTROL TO 
*         THE LOAD COMPLETION ROUTINE *CPL*.  WE MUST ADD A *LOAD*
*         REQUEST TO THE FRONT OF *TREQ* SO THAT *SEGRES* KNOWNS
*         WHICH FILE TO LOAD. 
  
  
 PASS2    SX6    P1+IP.LBUF 
          SX7    P1 
          SA6    LM          RESET FWA AND LIMIT FOR FET *L*
          SA7    L+1
          SA6    L+4
          RJ     LSO         LOAD SEGMENT OVERLAYS
          IFTEST NE,IP.MECS,0,1 
          RJ     REI         REWRITE ECS IMAGE
          RJ     CBF         COMPLETE BINARY FILE 
          SA1    FE 
          NZ     X1,ABEND    IF FATAL ERROR THEN ABORT WITH NO LOAD TABLE 
          ALLOC  TREQ,2,FRONT 
          SA1    OF          PASS *SEGRES* BINARY IN *LOAD* REQUEST 
          SX7    CLOAD*10000B+1 
          BX6    X1 
          LX7    36 
          SA6    X2+B1
          SA7    X2 
 K        IFNOS 
          SA1    Z1          ADD SCRATCH FILE TO *TSFR* 
          SA2    TSFR 
          RJ     AET= 
 K        ENDIF 
          RJ     //CPL       COMPLETE LOAD AND GENERATE MAP 
          TITLE  SEGMENT GENERATION - PASS 2 MAIN ROUTINES. 
 CBF      SPACE  4,8
**        CBF - COMPLETE BINARY FILE. 
* 
*              TO COMPLETE THE BINARY FILE THE TABLE *TCEL* IS WRITTEN
*         AS A SEPARATE RECORD AND A RANDOM INDEX IS WRITTEN
*         CONTAINING THE TRANSFER NAMES AND THEIR ADDRESSES.
* 
*         USES   X - 1, 3, 4, 6, 7. 
*                B - NONE.
*                A - 1, 3, 4, 6, 7. 
*         CALLS  CIO=, GBI, WFN, WTW=.
  
 CBF      PS                 ENTRY/EXIT 
          SX6    EA 
          SA6    L+6         MAKE WRITE AT EOI
          RJ     WFN         WRITE FILE NAME IF BINARY FILE NOT ON DISK 
          SA3    TCEL 
          SA4    A3+B1
          WRITEW L,X3,X4     WRITE *TCEL* 
          WRITER L,RCL
          RJ     GBI         GENERATE BINARY FILE INDEX 
          RJ     WFN         WRITE FILE NAME IF BINARY FILE NOT ON DISK 
          SA4    TSCR 
          SA1    A4+B1
          ZR     X6,CBF1     IF FILE IS ON RANDOM DEVICE
          WRITEW L,X4,X1
          WRITEF L,RCL
          SA1    SEGBBB 
          BX7    X1 
          SX6    B0 
          SA7    OF          SET FILE NAME FOR MAP AND *SEGRES* 
          SA6    TSCR+1 
          EQ     CBF
  
 CBF1     LX1    18 
          BX6    X4+X1       INDEX BUFFER ADDRESS + LENGTH
          SA6    L+7         PUT INDEX INFO INTO FET
          CIOCALL L,RCL,CLOSE 
          SX6    B0 
          SA6    TSCR+1 
          EQ     CBF
 LSO      SPACE  4,8
**        LSO - LOAD SEGMENT OVERLAY. 
* 
*              TO GENERATE A SEGMENT OVERLAY WE START AT THE SEGMENT
*         ENTRY IN *TBLK* AND LOAD ALL BLOCKS AND PROGRAMS UNTIL THE
*         NEXT SEGMENT ENTRY OR END OF TABLE IS ENCOUNTERED IN *TBLK*.
*         WE NOW COMPLETE THE DELINK TABLE AND WRITE THE OVERLAY ONTO 
*         THE BINARY FILE.  THE *TCEL* ENTRY FOR THIS SEGMENT HAS THE 
*         DISK ADDRESS INSERTED INTO THE APPROPRIATE FIELD. 
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3.
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  APS=, LSP, LBC, XLBC, FBC, CPR, CDT, WFN, WSO, WTW=, 
*                ATS=.
  
  
 LSO      PS                 ENTRY/EXIT 
 LSO1     SA1    TBLK 
          SA2    CS 
          MX7    0
          IX3    X1+X2
          SA7    BI 
          SA7    DE          RESET DELINK ENTRY INDEX 
          SA7    PI          SET INDEX FOR NO PROGRAMS READ YET 
          SA3    X3+B1       SEGMENT DEFINITION 
          SA7    TPGM+1      CLEAR *TPGM* 
          SX7    X3          SET ORIGIN AND PROGRAM ADDRESS 
          SX6    X2 
          SA7    PA 
          SA6    SI          SAVE CURRENT SEGMENT INDEX 
          SA7    PO 
          SA6    UN          SET INDEX FOR SEARCH TO FIND UNIQUE NAME 
          SX6    X2+2 
          AX3    24 
          SA6    A2          INCREMENT CURRENT INDEX
 DB       IFTEST NE,IP.LDBG,0 
          SA1    A3-B1
          MX6    42 
          SX2    1R 
          BX6    X6*X1
          BX6    X6+X2
          LX6    -6 
          SA1    DBG
          SA2    A1+B1
          SA6    MSGL2+2     ADD SEGMENT NAME TO MESSAGE
          BX7    X1 
          LX6    X2 
          SA7    A6-B1
          SA6    MSGL2-1
 DB       ENDIF 
          MX2    0
          SX1    X3          LENGTH OF DELINK TABLE 
          RJ     APS=        ALLOCATE PROGRAM SPACE 
          SB2    X2          FWA OF *TPGM*
          SX6    -1          SET TO NON-ZERO FOR *SEGRES* 
          SB3    X3+B2       LWA+1 OF *TPGM 
 LSO2     SA6    B2 
          SB2    B2+B1
          LT     B2,B3,LSO2  IF PRESET NOT COMPLETE 
          RJ     LSP         LOAD SEGMENT PROGRAMS
          RJ     LBC         PROCESS LINK BYTE CHAINS 
          RJ     XLBC        PROCESS EXTENDED LINK BYTE CHAINS
          RJ     FBC         PROCESS FILL BYTE CHAINS 
          RJ     CPR         COMPLETE READ OF PROGRAMS
          RJ     CDT         COMPLETE DELINK TABLE
          SA2    SN 
          SA1    TCEL 
          SX6    X2+B1
          LX2    1
          SA6    A2          INCREMENT SEGMENT NUMBER 
          IX3    X2+X1
          SA4    DA 
          SA3    X3 
          LX4    30 
          BX7    X4+X3
          SA7    A3          ADD DISK ADDRESS TO *TCEL* ENTRY 
          SETFET L,OF,BINARY WRITE SEGMENT OVERLAY INTO BUFFER
          MX6    1
          SA1    L+1
          LX6    48          SET RANDOM BIT IN FET
          BX6    X6+X1
          SA6    A1 
          RJ     WFN         WRITE FILE NAME IF BINARY FILE NOT ON DISK 
          SA3    TPGM 
          SA4    A3+B1
          WRITEW L,X3,X4
          SA1    PA 
          SA2    PO 
          IX1    X1-X2       LENGTH OF SEGMENT OVERLAY
          RJ     WSO         WRITE SEGMENT OVERLAY
          MX6    0
          SA6    LI          CLEAR LINK BYTE INFO FOR NEXT SEGMENT
          SA6    XLI
          SA6    TLBC+1 
          SA6    TXLBC+1
          SA1    CS 
          SA2    TBLK+1 
          IX6    X1-X2
          MI     X6,LSO1     IF MORE SEGMENTS TO BE GENERATED 
          SA1    ID 
          LX1    59 
          PL     X1,LSO3     IF NOT WRITING *ZZZZZDT* 
          WRITER  O,RCL      COMPLETE WRITE 
          SA1    O+1         SET FET *O* TO EMPTY BUFFER
          SX6    X1 
          SA6    A1+4-1 
          SA6    LM          SET NEW LOW MEMORY ADDRESS 
 LSO3     MX7    0
          SA7    TRLB+1      CLEAR *TRLB* 
          SA7    SN          SET SEGMENT NUMBER TO ROOT FOR *ELT* 
          IFTEST NE,IP.LDBG,0,1 
          SA7    MSGL2-1
          SA1    TPGM+1 
          SX2    COMLTH 
          IX6    X1-X2
          AX6    60 
          BX1    X6*X1
          BX2    -X6*X2 
          BX1    X1+X2
          ALLOC  TPGM,X1     RESET *TPGM* FOR DUMMY COMMUNICATIONS AREA 
          EQ     LSO
 REI      SPACE  4,8
 ECS      IFTEST NE,IP.MECS,0 
**        REI - REWRITE ECS IMAGE.
* 
*              WE HAVE ALREADY PREALLOCATED THE ECS LABELLED COMMON 
*         BLOCK IMAGE IN THE BINARY FILE AND WE CALL THIS ROUTINE TO
*         REWRITE THE ECS IMAGE.
* 
*         ENTRY  *L* = FET INITIATED FOR WRITE ONTO BINARY FILE.
*         USES   X - 0, 1, 2, 3, 4, 5, 6, 7.
*                B - 2, 5.
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  SMS=, WFN, REW=, CIO=. 
  
  
 REI      PS                 ENTRY/EXIT 
          SA3    TBLK 
          SA2    X3+3        ECS // DEFINITION
          MX0    -24
          BX0    -X0*X2      (X0) = FWA OF ECS // = LENGTH OF REWRITE 
          ZR     X0,REI      IF NO ECS IMAGE
          SMSG   DBG8 
          SA2    L+1
          SX6    X2 
          SA6    A2+B1       IN = FWA 
          SA6    A6+B1       OUT = FWA
          RJ     WFN         WRITE FILE NAME IF BINARY FILE NOT ON DISK 
          SX5    B0          (X5) = CURRENT ECS ADDRESS 
          BX6    -X6         0 OR -1
          SB2    IPLBUF 
          SA4    L+1         FWA
          SX7    X4+B2
          SB2    X6+B2       (B2) = AMOUNT OF ECS TO READ TO FILL BUFF
          SA2    EA 
          SX6    X7+B1
          MX7    1
          SB5    X2          (B5) = CURRENT DISK ADDRESS FOR REWRITE
          LX7    -12
          SA6    L+4
          BX7    X7+X4
          SA7    A4          SET RANDOM BIT 
 REI1     BX1    X5 
          SX7    B5 
          SA2    L+2         CM FWA FOR ECS READ
          SX6    X2+B2
          SA6    A2          SET IN = FULL BUFFER 
          SA7    L+6         SET DISK ADDRES FOR REWRITE
          SX6    B2 
          IX5    X5+X6
          IX3    X5-X0
          PL     X3,REI2     IF LESS THAN BUFFERFULL
          SX3    B2+B1
          AX3    6           /100B
          SB5    B5+X3       SET NEXT DISK ADDRESS
          RJ     REW=        READ ECS INTO BUFFER 
          REWRITE L,RCL      REWRITE ECS IMAGE
          SA2    X2+B1
          SX6    X2 
          SB2    IPLBUF 
          SA6    L+3         OUT = FWA
          SA6    A6-B1       IN=FWA 
          EQ     REI1 
  
 REI2     IX5    X5-X6
          IX3    X0-X5
          SB2    X3          LENGTH OF ECS READ 
          IX7    X2+X3
          SA7    A2          IN = PARTIAL BUFFER
          RJ     REW=        READ ECS 
          CIOCALL L,RCL,REWRITER
          SA1    L+1
          SX6    X1+IP.LBUF 
          SA6    L+4         RESET LIMIT
          EQ     REI
 ECS      ENDIF 
          TITLE  SEGMENT GENERATION - PASS 2 TABLE PROCESSORS.
 PDL      SPACE  4,8
**        PDL - SECOND PASS PROCESSING OF *PIDL* TABLE. 
* 
*              *PIDL* TABLE PROCESSING DURING SEGMENT LOADING IS
*         DIFFERENT THAN RELOCATABLE LOADING BECAUSE THE ENTRIES
*         FROM THE *PIDL* TABLE ARE ALREADY IN *TBLK*.  SO CONTROL IS 
*         TRANSFERRED HERE FROM *PIDL* TABLE PROCESSING IN QUAL *READ*
*         TO SET UP THE APPROPRIATE TABLES AND GLOBAL VARIABLES.  WE
*         THEN RETURN CONTROL TO THE *PIDL* TABLE PROCESSOR TO CONTINUE 
*         THE LOAD. 
* 
*         ENTRY  (B7) = LENGTH OF *PIDL* TABLE. 
*                (X5) = START OF *PIDL* TABLE READ INTO *TRLB*. 
*                *CS* = INDEX FOR NEXT ENTRY IN *TBLK*. 
*                *TRLB* ALLOCATED AND *PIDL* READ INTO IT.
*         EXIT   TO /READ/PDL2A 
*                (X4) = LENGTH OF PROGRAM.
*                (X5) = PROGRAM ADDRESS.
*                *PI* = PROGRAM INDEX.
*                *PN* = PROGRAM NAME. 
*                *FI* = FILE INDEX OF ORIGINAL SOURCE.
*                *TRLB* = RELOCATION BASE INITIALIZED.
*         USES   ALL REGISTERS EXCEPT B1. 
  
  
 PDL      SA1    ID 
          SA2    T1 
          LX1    59 
          PL     X1,PDL0     IF NOT TO SAVE TABLES FOR *PMD*
          BX6    X2 
          WRITEO  O          WRITE *PIDL* HEADER WORD 
          SA1    TRLB 
          SX1    X1+2 
          WRITEW  O,X1,X0+B1 WRITE REMAINDER OF *PIDL* TABLE
 PDL0     SA1    CS 
          SX6    X1-2 
          SA6    PI          SET PROGRAM INDEX
          SA2    TBLK 
          SB2    X2          (B2) = FWA OF *TBLK* 
          SA3    X6+B2       PROGRAM ENTRY
          SA4    A3+B1
          MX6    42 
          BX6    X6*X3
          SA6    PN          SAVE PROGRAM NAME
          SA1    TPRX 
          SA1    X1          GET *TPRX* POINTER 
          MX7    0
          LX1    3
          SA7    A1          ZERO THE *TPRX* POINTER
          BX6    X1+X3       ADD *TPRX* TO PROGRAM DEFINITION 
          SA6    A3 
          AX4    -12
          SX7    X4 
          SA7    FI          SET FILE INDEX 
          MX0    42 
          SA1    TRLB 
          SA2    A1+B1
          SB4    B1+B1       (B4) = 2 
          SB5    X1          (B5) = FWA OF *TRLB* 
          SB6    X2          (B6) = LENGTH OF *TRLB*
          SB7    B4          (B7) = CURRENT ENTRY IN *TRLB* 
 PDL1     SB7    B7+B1
          GE     B7,B6,PDL9  IF END OF COMMON BLOCKS
          SA1    B5+B7       *PIDL* TABLE ENTRY 
          MX2    1
          SX6    X1          SIGN EXTEND *T* BIT
          SA3    BC 
          BX6    X2*X6       *E* BIT = ECS/CM BIT 
          BX4    X1-X3
          BX4    X0*X4
          LX7    X6,B4       *E* BIT AS IN *TBLK* ENTRY 
          ZR     X4,PDL6     IF BLANK COMMON
          SA3    SI 
          BX2    X0*X1
          SB3    X3          (B3) = CURRENT INDEX TO START *TBLK* SEARCH
          SA4    LSBN 
          BX4    X4-X2
          NZ     X4,PDL1C    IF NOT LOCAL SAVE BLOCKS 
          SA1    PN 
          SA4    TLSB 
          SA4    X4-1 
 PDL1A    SA4    A4+B4       FIND CORRESPONDING TLSB ENTRY
          BX4    X4-X1
          NZ     X4,PDL1A    IF NO MATCH
          SA2    A4-B1
 PDL1C    BSS    0
          ZR     X2,PDL7     IF LOCAL BLOCK 
          SX4    B4 
          BX2    X2+X7       ADD *E* BIT
          BX4    X0+X4       MASK FOR *TBLK* MATCH
 PDL2     SB3    B3+B4
          SA1    B3+B2       *TBLK* ENTRY 
          BX3    X4*X1       NAME + ECS/CM BIT
          BX3    X3-X2
          NZ     X3,PDL2     IF NOT THE ENTRY WE WANT 
 PDL3     SX7    B3+B1       DEFINITION INDEX 
          LX7    36 
          BX6    X6+X7
          SA2    A1+B1       *TBLK* DEFINITION
          LX1    -1 
          PL     X1,PDL4     IF PROGRAM BLOCK DO NOT INCREMENT COUNT
          MX7    1
          LX7    -11
          IX7    X7+X2
          SA7    A2          INCREMENT COUNT FOR CONDITIONAL TABLES 
 PDL4     MX3    -12
          MX4    -24
          BX2    -X4*X2      *PA* 
          LX3    5
          BX3    -X3*X1      OWNER OF THIS BLOCK
          SA4    PO 
          NZ     X3,PDL10    IF A GLOBAL OR EQUAL BLOCK 
          MI     X6,PDL5     IF ECS BLOCK 
          IX2    X2-X4       PA-PO+BI (BI=0) = LOAD ADDRESS 
 PDL5     BX6    X2+X6
          SA6    B5+B7       SAVE *TRLB* ENTRY
          EQ     PDL1 
  
 PDL6     SX7    X7+B1       1 OR 3 
          LX7    36 
          BX6    X6+X7       ECS/CM BIT + *PI*
          EQ     PDL10       SET *PA* = -0
  
 PDL7     SA3    UN          INDEX TO LAST UNIQUE NAME USED 
          SB3    X3 
          MX4    12 
          SA2    UD          UNIQUE NAME PREFIX 
 PDL8     SB3    B3+B4
          SA1    B3+B2       *TBLK* ENTRY 
          BX3    X4*X1
          BX3    X3-X2       COMPARE FIRST TWO CHARACTERS OF NAME 
          NZ     X3,PDL8     IF THIS CANNOT BE A UNIQUE NAME
          SX7    B3 
          SA7    UN          SAVE INDEX OF LAST LOCAL BLOCK NAME
          EQ     PDL3 
  
 PDL9     SA5    PA 
          SA1    PI 
          SX1    X1+B1       DEFINITION INDEX 
          SA4    X1+B2       *TBLK* DEFINITION
          SA3    TRLB 
          SA2    PO 
          LX1    36 
          AX4    24          LENGTH OF PROGRAM
          IX2    X5-X2       PA-PO+BI (BI=0) = LOAD ADDRESS 
          BX6    X1+X2
          SA6    X3 
          SA6    X3+B1       SAVE POSITIVE PROG RELOC 
          SA6    A6+B1
          EQ     /READ/PDL2A RETURN TO CONTINUE PROGRAM LOAD
  
 PDL10    MX4    -24
          BX6    -X4-X6      SET *PA* = -0 FOR OUTSIDE THIS SEGMENT 
          SA6    B5+B7
          EQ     PDL1 
          TITLE  SEGMENT GENERATION - PASS 2 SUBROUTINES. 
 CDT      SPACE  4,8
**        CDT - COMPLETE DELINK TABLE.
* 
*              AFTER A SEGMENT OVERLAY HAS BEEN COMPLETED, THE DELINK 
*         TABLE CONTAINS ALL REFERENCES TO EXTERNALS WHICH MAY CAUSE
*         LOADING.  WE MUST DELETE ALL DUPLICATES AND SORT THE TABLE
*         INTO A FORMAT EXPECTED BY *SEGRES*.  IF TWO REFERENCES ARE
*         MADE FROM THE SAME WORD, WE MUST CHECK THAT THEY CAUSE LOADING
*         OF COMPATIBLE SEGMENTS OTHERWISE AN ERROR IS ISSUED.  FOR 
*         DUPLICATIOES WE SET THE DELINK ENTRY OF ONE OF THEM TO -1 
*         (THUS THE UPPER 12 BITS ARE NON-ZERO SO *SEGRES* WILL NOT 
*         CONFUSE THESE WITH DELINK ENTRIES).  *SEGRES* EXPECTS THE 
*         ENTRIES TO BE SORTED INTO INCREASING ORDER AND THAT THE 
*         LAST ENTRY OF A GROUP (ENTRIES CALLING SAME SEGMENT) TO 
*         HAVE BIT 17 SET.
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4, 6.
*                A - 1, 2, 3, 4, 6. 
*         CALLS  CCS, ERROR, STB. 
  
  
 CDT      PS                 ENTRY/EXIT 
          SA2    DE 
          SA1    TPGM 
          ZR     X2,CDT      IF NO DELINK TABLE 
  
*         DELETE DUPLICATE REFERENCES FROM SAME WORD. 
  
          MX3    -18
          RJ     STB         SORT BY REFERENCE ADDRESS
          SA1    TPGM 
          SA2    DE 
          SB4    B1          (B4) = CURRENT INDEX INTO DELINK TABLE 
          MX7    -18
          SB6    X2          (B6) = LENGTH OF DELINK TABLE
 CDT1     GE     B4,B6,CDT2  IF THIS IS END OF TABLE
          SA4    X1+B4
          SB4    B4+B1
          SA3    A4-B1
          BX6    X3-X4
          BX6    -X7*X6 
          NZ     X6,CDT1     IF NOT SAME ADDRESS
          BX2    -X7*X3      ADDRESS OF EXECUTABLE WORD 
          AX3    18 
          AX4    18 
          SB2    X3 
          SB3    X4 
          SB2    B2+B2
          SB3    B3+B3
          IX6    X3-X4
          AX6    60 
          BX3    -X6*X3 
          BX6    X6*X4
          IX3    X3+X6       MAX OF SEGMENT ORDINALS
          SX6    -B1
          LX3    18 
          SA6    A3          SET PREVIOUS ENTRY TO -1 
          BX6    X2+X3
          SA6    A4          SET NEW WORD TO HIGHEST COMPATIBLE SEGMENT 
          RJ     CCS         CHECK FOR COMPATIBLE SEGMENT 
          SA1    TPGM 
          PL     X6,CDT1     IF NOT CONFLICTING REFERENCES IN SAME WORD 
          SA2    SI 
          SA4    A4 
          LX2    18 
          BX4    -X7*X4 
          BX7    X4+X2
          ERROR  4450,X7     ---- CONFLICTING SEGMENTS CALLED BY SAME 
          SA1    TPGM 
          MX7    -18
          EQ     CDT1 
  
*         SET BIT 18 FOR LAST ENTRY OF A GROUP. 
  
 CDT2     SX2    B6 
          MX3    30          USE LOWER 30 BITS FOR SORT 
          RJ     STB         SORT DELINK TABLE
          SA1    TPGM 
          SA2    DE 
          SB4    B1          (B4) = CURRENT INDEX INTO DELINK TABLE 
          MX7    -18
          SB2    X1          (B2) = FWA OF DELINK TABLE 
          MX3    1
          SB3    X2          (B3) = LENGTH OF DELINK TABLE
          SA4    B2          (X4) = LAST ENTRY TRIED
          LX3    18 
          SA1    B2          (X1) = FIRST ENTRY OF A GROUP
 CDT3     GE     B4,B3,CDT4  IF THIS IS LAST ENTRY OF TABLE 
          SA4    B2+B4       NEXT DELINK ENTRY
          SB4    B4+B1
          BX6    X4-X1
          BX6    X7*X6
          ZR     X6,CDT3     IF IN SAME SEGMENT 
          SA2    A4-B1
          BX6    X2+X3       SET BIT FOR LAST ENTRY OF A GROUP
          SA6    A2 
          BX1    X4 
          EQ     CDT3 
  
 CDT4     BX6    X4+X3
          SA6    A4          SET BIT FOR LAST ENTRY OF A GROUP
          EQ     CDT
 FCE      SPACE  4,8
**        FCE - FIND COMPATIBLE ENTRY POINT DEFINITION. 
* 
*              THIS ROUTINE IS CALLED BY *ELT* TO FIND THE COMPATIBLE 
*         ENTRY POINT GIVEN THE SEGMENT NUMBER OF THE SEGMENT MAKING
*         THE REFERENCE.
* 
*         ENTRY  (X1) = ENTRY NAME (18/0,42/NAME).
*                (X2) = DEFINITION OF FIRST ENTRY IN *TLNK*.
*                (X6) = INDEX OF FIRST ENTRY DEFINITION.
*                (B3) = FWA OF TABLE. 
*                *SN* = CURRENT SEGMENT ORDINAL.
*         EXIT   (X2) = COMPATIBLE ENTRY POINT DEFINITION.
*                (X6) = INDEX OF COMPATIBLE DEFINITION. 
*         USES   X - 2, 3, 4, 6, 7. 
*                B - 2, 3, 4. 
*                A - 2, 3, 4, 7.
*         CALLS  CCS. 
  
  
 FCE      PS                 ENTRY/EXIT 
          MX3    2
          LX3    -1 
          BX3    X3*X2
          SX7    B6 
          NZ     X3,FCE      IF UNSATISFIED OR OMITTED
          SA7    FCEA        SAVE B6
          SX7    B0 
          SA7    FCEC        SET NO COMPATIBLE ENTRY POINT SO FAR 
          SA4    TLNK+1 
          SA3    SN 
          BX7    X1 
          SA7    FCEB        SAVE X1
          SB6    X6          (B6) = INDEX OF DEFINITION 
          SX7    B3          (X7) = FWA OF TABLE
          LX3    1
          SB4    X4          (B4) = LENGTH OF *TLNK*
          SB2    X3          (B2) = SEGMENT INDEX OF CALLING PROGRAM
 FCE1     SB3    B6-B1
          GE     B3,B4,FCE3  IF END OF *TLNK* 
          SA4    X7+B3
          BX4    X4-X1
          NZ     X4,FCE3     IF NAME DOES NOT MATCH 
          AX2    24 
          MX6    -12
          BX6    -X6*X2 
          SB3    X6 
          SB3    B3+B3       SEGMENT INDEX OF SEGMENT DEFINING ENTRY
          RJ     CCS         CHECK FOR COMPATIBLE SEGMENTS
          ZR     X6,FCE2     IF COMPATIBLE AND WON-T CAUSE LOADING
          MI     X6,FCE1A    IF NOT COMPATIBLE
          SA2    FCEC 
          NZ     X2,FCE1A    IF FIRST COMPATIBLE ENTRY ALREADY FOUND
          BX2    X7          SAVE X7
          SX7    B6 
          SA7    A2          SET FIRST COMPATIBLE ENTRY POINT INDEX 
          BX7    X2          RESTORE X7 
 FCE1A    BSS    0
          SB6    B6+2 
          SA2    FCEB 
          BX1    X2          RESTORE X1 
          SA2    X7+B6       TRY NEXT ENTRY POINT DEFINITION
          EQ     FCE1 
  
 FCE2     SX6    B6          INDEX OF DEFINITION
          SA3    FCEA 
          SA2    X7+B6       DEFINITION 
          SB6    X3          RESTORE B6 
          EQ     FCE
  
 FCE3     SA3    FCEC        CHECK FIRST COMPATIBLE ENTRY FOUND 
          ZR     X3,FCE2     IF NO COMPATIBLE ENTRY FOUND 
          SB6    X3          (B6) = INDEX OF FIRST COMPATIBLE ENTRY 
          EQ     FCE2 
  
 FCEA     CON    0           SAVE AREA
 FCEC     CON    0           SAVE AREA
 FCEB     CON    0           SAVE AREA
 GBI      SPACE  4,8
**        GBI - GENERATE BINARY FILE INDEX. 
* 
*              THIS ROUTINE IS CALLED TO GENERATE THE INDEX BUFFER
*         FOR THE BINARY FILE.  THE FIRST WORD OF THE BINARY
*         FILE HAS THE FORMAT.
* 
*         VFD    1/E,5/0,24/ECSBLK,9/WC,21/PRU                           LDR0167
* 
*         E      IS SET IF NO ECS IMAGE APPEARS IN THE BINARY.           LDR0167
*         ECSBLK IS THE LWA+1 OF ECS BLANK COMMON.                       LDR0167
*         WC     IS THE NUMBER OF ENTRY POINTS FOLLOWING THIS WORD. 
*         PRU    IS THE DISK ADDRESS OF *TCEL* TABLE WITHIN THIS FILE.
* 
*              EACH TRANSFER ENTRY POINT MUST BE WITHIN THE ROOT SEGMENT
*         OTHERWISE A FATAL ERROR OCCURS.  WE ALSO SET THE APPROPRIATE
*         TRANSFER NAME AND ADDRESS FOR THE MAP.
* 
*         USES   X - 1, 2, 3, 6, 7. 
*                B - 6, 7.
*                A - 1, 2, 3, 6.
*         CALLS  ADW=, ERROR. 
  
  
 GBI      PS                 ENTRY/EXIT 
          SA1    TREQ 
          SX6    B0 
          SA2    A1+B1
          SA6    TSCR+1 
          SA3    X1 
          MX6    -12
          AX3    36 
          BX6    -X6*X3      *WC* OF *NOGO* OR *EXECUTE*
          SB6    X2          (B6) = LENGTH OF *TREQ*
          SB7    X6+B1       (B7) = CURRENT INDEX IN *TREQ* 
          SA3    DA 
          SA1    TBLK 
          SA2    X1+3                                                    LDR0167
          MX6    -24                                                     LDR0167
          BX1    -X6*X2      LENGTH OF ECS LABELLED COMMON               LDR0167
          AX2    24                                                      LDR0167
          BX2    -X6*X2      LENGTH OF ECS BLANK COMMON                  LDR0167
          IX2    X2+X1       LWA+1 OF ECS BLANK COMMON                   LDR0167
          LX2    30                                                      LDR0167
          NZ     X1,GBI0     IF ECS LABELLED COMMON PRESENT              LDR0167
          MX6    1                                                       LDR0167
          BX2    X6+X2       SET BIT FOR NO ECS IMAGE                    LDR0167
 GBI0     BX6    X2+X3                                                   LDR0167
          GE     B7,B6,GBI4  IF NO ENTRY POINTS GIVEN OF *END* DIRECTIVE
          SX3    B6-B7
          LX3    21 
          BX1    X6+X3
          ADDWRD TSCR,X1
          SA3    TREQ 
          SA1    X3+B7
          BX6    X1 
          SA6    XF+1        USE FIRST NAME GIVEN FOR TRANSFER NAME 
 GBI1     SA1    TREQ 
          GE     B7,B6,GBI5  IF END OF TRANSFER NAMES 
          SA1    X1+B7
          SB7    B7+B1
 GBI2     MX2    0
          RJ     ELT         FIND TRANSFER NAME 
          SA1    A1 
          ZR     X2,GBI3     IF NAME NOT FOUND
          SX6    X2          TRANSFER ADDRESS 
          MX3    -12
          AX2    24 
          BX3    -X3*X2 
          NZ     X3,GBI3     IF ENTRY NOT IN ROOT SEGMENT 
          BX1    X1+X6
          ADDWRD TSCR,X1
          EQ     GBI1 
  
 GBI3     BX7    X1 
          ERROR  106,X7      ---- TRANSFER POINT NOT FOUND
          EQ     GBI1 
  
 GBI4     SX3    B1 
          LX3    21 
          BX1    X6+X3
          ADDWRD TSCR,X1
          SX6    B0 
          SA1    XF+1        USE LAST *XFER* NAME AS TRANSFER ADDRESS 
          SA6    A1+B1       SET *XF* + 2 = 0 
          ZR     X1,GBI      IF NO TRANSFER NAME - ERROR IN *CPL* 
          EQ     GBI2 
  
 GBI5     SA3    X1 
          MX6    -12
          AX3    36 
          BX6    -X6*X3      *WC* OF *NOGO* OR *EXECUTE*
          SX6    X6+B1
          SA6    A1+B1       RESET LENGTH OF *TREQ* 
          EQ     GBI
 LBC      SPACE  4,8
**        LBC - PROCESS LINK BYTE CHAINS FOR DELINK TABLE.
* 
*              ALL EXTERNAL REFERENCES FROM *LINK* TABLES WHICH MAY 
*         CAUSE LOADING WILL HAVE AN ENTRY IN THE DELINK
*         TABLE OF THE FORMAT 30/0,12/SEGMENT NUMBER,18/ADDRESS.
*         THIS ROUTINE FORMS THESE ENTRIES AND STORES THEM IN THE SPACE 
*         ALREADY ALLOCATED IN *TPGM*.  LATER, IN ROUTINE *CDT*, THESE
*         ENTRIES WILL BE SORTED AND DUPLICATES REMOVED.
* 
*         USES   X - 0, 1, 2, 3, 5, 6, 7. 
*                B - 2, 3, 5, 6, 7. 
*                A - 1, 2, 3, 6, 7. 
*         CALLS  SEN, ELT, CCS. 
  
  
 LBC      PS                 ENTRY/EXIT 
          SA1    TLBC 
          SB7    B0          (B7) = CURRENT INDEX IN *TLBC* 
          SA2    A1+B1
          SB5    X1          (B5) = FWA OF *TLBC* 
          SB6    X2          (B6) = LENGTH OF *TLBC*
 LBC1     GE     B7,B6,LBC   IF TABLE SCAN COMPLETE 
          SA1    B5+B7
          SB7    B7+B1
          ZR     X1,LBC1     IF SEQUENCE TERMINATOR 
          MI     X1,LBC2     IF A TRAILER BYTE
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          MX2    0
          RJ     ELT         FIND COMPATIBLE ENTRY POINT
          MX3    2
          LX3    -1 
          BX3    X3*X2
          SX0    B0 
          NZ     X3,LBC1     IF UNSATISFIED OR OMITTED
          AX2    24 
          MX6    -12
          BX6    -X6*X2 
          SB3    X6 
          SB3    B3+B3       SEGMENT INDEX OF SEGMENT DEFINING ENTRY
          SA3    SN 
          LX3    1
          SB2    X3 
          RJ     CCS         CHECK COMPATIBILITY OF SEGMENTS
          ZR     X6,LBC1     IF NO LOADING WILL OCCUR 
          SX0    B3 
          LX0    17          (X0) = INDEX OF REFERENCED SEGMENT 
          EQ     LBC1 
  
 LBC2     ZR     X0,LBC1     IF WE ARE NOT ADDING TO DELINK TABLE 
          MX5    -30
          BX5    -X5*X1 
          LX1    3
          LX5    30 
          MI     X1,LBC3     IF ADDRESS IS ECS ADDRESS
          SA2    PO 
          LX1    27 
          SX1    X1 
          IX1    X1+X2       ADDRESS OF REFERENCE 
          BX6    X0+X1
          SA2    DE 
          SA3    TPGM 
          SX7    X2+B1
          IX3    X2+X3
          SA7    A2 
          SA6    X3 
 LBC3     PL     X5,LBC1     IF NOT A TRAILER BYTE
          LX5    3
          MI     X5,LBC1     IF ADDRESS IS ECS ADDRESS
          SA2    PO 
          LX5    27 
          SX1    X5 
          IX1    X1+X2       REFERENCE ADDRESS
          BX6    X1+X0
          SA2    DE 
          SA3    TPGM 
          SX7    X2+B1
          IX3    X2+X3
          SA7    A2 
          SA6    X3 
          EQ     LBC1 
 LSP      SPACE  4,8
**        LSP - LOAD SEGMENT PROGRAMS.
* 
*              THIS ROUTINE IS CALLED TO SCAN FROM ONE SEGMENT ENTRY
*         IN *TBLK* TO ANOTHER ENTRY (OR END OF TABLE) LOADING
*         ALL BLOCKS AND PROGRAMS.  ECS BLOCKS HAVE ALREADY BEEN
*         ALLOCATED IN PASS 1.  EQUAL AND GLOBAL BLOCKS NOT DEFINED 
*         IN THIS SEGMENT WILL BE SKIPPED BECAUSE THEY WILL BE
*         ALLOCATED IN ANOTHER SEGMENT.  CM BLOCKS ARE ALLOCATED AND
*         PRESET BY CALLING *APS=*.  PROGRAM ENTRIES ENCOUNTERED CAUSE
*         US TO INITIATE THE READ OF THE PROGRAM AND CALL *RDR* TO
*         LOAD IT.
* 
*         ENTRY  *CS* = CURRENT INDEX IN *TBLK*.
*         EXIT   *CS* = INDEX OF NEXT SEGMENT ENTRY OR END OF *TBLK*. 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  SETFET=, APS=, CIO=, RDO=, RDR, LBC, XLBC, CPR.
  
  
 LSP      PS                 ENTRY/EXIT 
          SETFET L,Z1,BINARY
          MX6    1
          SA1    L+1
          LX6    48 
          BX6    X6+X1       SET RANDOM BIT 
          SA6    A1 
 LSP1     SA2    TBLK 
          SA1    CS 
          SA3    A2+B1
          IX4    X1+X2
          IX3    X1-X3
          SA4    X4          NEXT *TBLK* ENTRY
          PL     X3,LSP      IF END OF *TBLK* 
          SX6    4
          BX6    X6*X4       *S* BIT
          NZ     X6,LSP      IF SEGMENT ENTRY 
          LX4    59-1 
          SX7    X1+2 
          LX6    X4,B1       POSITION TO *T* BIT
          SA7    A1          INCREMENT CURRENT INDEX IN *TBLK*
          MI     X4,LSP1     IF ECS BLOCK 
          PL     X6,LSP3     IF PROGRAM BLOCK 
          LX4    1-4         POSITION TO *Q* BIT
          LX6    X4,B1       POSITION TO *G* BIT
          MI     X4,LSP1     IF AN *EQUAL* BLOCK
          MX2    0
          LX4    4-59        RESTORE ENTRY
          PL     X6,LSP2     IF THIS IS NOT A GLOBAL BLOCK
          SX6    X4 
          AX6    6           *OWN*
          NZ     X6,LSP1     IF GLOBAL BLOCK NOT DEFINED IN THIS SEGMENT
 LSP2     SA1    A4+B1       *TBLK* DEFINITION
          AX1    24 
          SX1    X1          LENGTH 
          RJ     APS=        ALLOCATE PROGRAM SPACE 
          EQ     LSP1 
  
 LSP3     SA1    A4+B1
          MX7    -24
          SX6    X1 
          BX7    X7*X1       REMOVE OLD *PA*
          SA2    PA 
          SA6    L+6         PUT DISK ADDRESS IN FET FOR RANDOM READ
          BX7    X7+X2       ADD *PA* TO PROGRAM DEFINITION 
          SA7    A1 
          AX1    -12
          SX6    X1 
          SA6    FI 
          READ   L
          READO  L
          SA6    T1 
          BX5    X6 
          RJ     /READ/RDR
          SA1    TLBC+1 
          SA2    TXLBC+1
          IX3    X1+X2
          SX4    X3-400B
          MI     X4,LSP1     IF LINK BYTE TABLES ARE NOT TOO BIG
          RJ     LBC         PROCESS LINK BYTE CHAINS 
          RJ     XLBC        PROCESS EXTENDED LINK BYTE CHAINS
          RJ     CPR         COMPLETE READ SO FAR-EMPTY LINK TABLES 
          EQ     LSP1 
 SBT      SPACE  4,8
**        STB - SORT TABLE. 
* 
*               THIS ROUTINE SORTS A TABLE SO AS TO PLACE THE VALUES IN 
*         THE SPECIFIED ADDRESS FIELD IN ASCENDING ORDER. 
* 
*         ENTRY  (X1) = FWA OF TABLE. 
*                (X2) = LENGTH OF TABLE.
*                (X3) = MASK INDICATING ADDRESS SIZE = VFD  60-ADR/ADR
*         EXIT   TABLE SORTED.
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4, 5, 6, 7.
*                A - 0, 1, 2, 6, 7. 
  
  
 STB      PS                 ENTRY/EXIT 
          R=     A0,X1-1     FWA - 1
          SB7    X2          N = NO. OF ENTRIES 
          SB6    X2          M = NO. OF ENTRIES 
 STB1     SX6    B6 
          AX6    1
          SB6    X6          M = M/2
          SB3    B1          J = 1
          ZR     B6,STB      RETURN IF M = 0
          SB4    B7-B6       K = N-M
          SB2    B3          I = J
 STB2     SB5    B2+B6       L = I + M
          SA1    A0+B2
          BX6    -X3*X1      A(I) 
          SA2    A0+B5
          BX7    -X3*X2      A(L) 
          IX4    X7-X6
          PL     X4,STB3     IF A(L) > A(I) 
          BX6    X1          INTERCHANGE A(I) AND A(L)
          BX7    X2 
          SA6    A2 
          SA7    A1 
          SB2    B2-B6       I = I - M
          GT     B2,B0,STB2  IF I > 0 
 STB3     SB3    B3+B1       J = J + 1
          SB2    B3          I = J
          LE     B3,B4,STB2  IF J @ K 
          EQ     STB1 
 WFN      SPACE  4,8
**        WFN - WRITE FILE NAME FOR NON-RANDOM BINARY FILE. 
* 
*              IF WE ARE WRITING THE FILE ZZZZZ32 WE MUST PRECEDE 
*         EACH RECORD WITH THE NAME OF THE BINARY FILE. 
* 
*         EXIT   (X6) = NUMBER OF WORDS WRITTEN.
*         USES   X - 1, 3, 4, 6.
*                B - NONE.
*                A - 1, 3, 4. 
*         CALLS  WTO=.
  
  
 WFN      PS                 ENTRY/EXIT 
          SA3    SEGBBB 
          SA4    OF 
          IX6    X3-X4
          ZR     X6,WFN      IF BINARY FILE ON RANDOM ACCESS DEVICE 
          SA1    SEGBBB 
          BX6    X1 
          WRITEO L
          SX6    B1 
          EQ     WFN
 WSO      SPACE  4,8
**        WSO - WRITE SEGMENT OVERLAY.
* 
*              COMPLETE THE OVERLAY AND UPDATE THE DISK ADDRESS FOR 
*         THE START OF THE NEXT OVERLAY.
* 
*         ENTRY  (X1) = LENGTH OF OVERLAY.
*                *L* = FET INITIATED FOR *WRITER*.
*         EXIT   (DA) = UPDATED TO NEXT DISK ADDRES TO WRITE. 
*         USES   X - 2, 6.
*                B - NONE.
*                A - 2, 6.
*         CALLS  CIO=.
  
 WSO      PS                 ENTRY/EXIT 
          SA2    DA 
          SX6    100B 
          IX6    X6+X1
          AX6    6
          IX6    X6+X2
          SA6    A2          SET NEW STARTING DISK ADDRESS
          WRITER L,RCL
          EQ     WSO
 XLBC     SPACE  4,8
**        XLBC - PROCESS EXTENDED LINK BYTE CHAINS FOR DELINK TABLE.
* 
*              ALL EXTERNAL REFERENCES FROM *XLINK* TABLES WHICH MAY
*         CAUSE LOADING WILL HAVE AN ENTRY IN THE DELINK
*         TABLE OF THE FORMAT 30/0,12/SEGMENT NUMBER,18/ADDRESS.
*         THIS ROUTINE FORMS THESE ENTRIES AND STORES THEM IN THE SPACE 
*         ALREADY ALLOCATED IN *TPGM*.  LATER, IN ROUTINE *CDT*, THESE
*         ENTRIES WILL BE SORTED AND DUPLICATES REMOVED.  FOR *XLINK* 
*         TABLES, IT IS NECESSARY TO ENSURE THAT THE REFERENCE OCCURS ON
*         AN INSTRUCTION BOUNDARY AND THAT THE FIELD IS 18 BITS WIDE. 
* 
*         USES   X - 0, 1, 2, 3, 4, 6, 7. 
*                B - 2, 3, 5, 6, 7. 
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  SEN, ELT, CCS. 
  
  
 XLBC     PS                 ENTRY/EXIT 
          SA1    TXLBC
          SB7    B0          (B7) = CURRENT INDEX IN *TXLBC*
          SA2    A1+B1
          SB5    X1          (B5) = FWA OF *TXLBC*
          SB6    X2          (B6) = LENGTH OF *TXLBC* 
 XLBC1    GE     B7,B6,XLBC  IF TABLE SCAN COMPLETE 
          SA1    B5+B7
          SB7    B7+B1
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          MX2    0
          RJ     ELT         FIND COMPATIBLE ENTRY POINT
          SX0    B0 
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,XLBC2    IF UNSATISFIED OR OMITTED
          AX2    24 
          MX6    -12
          BX6    -X6*X2 
          SA3    SN 
          SB3    X6 
          LX3    1
          SB3    B3+B3
          SB2    X3 
          RJ     CCS         CHECK SEGMENT COMPATIBILITY
          ZR     X6,XLBC2    IF NO LOADING WILL OCCUR 
          SX0    B3 
          LX0    17 
 XLBC2    GE     B7,B6,XLBC  IF END OF TABLE SCAN 
          SA1    B5+B7
          SB7    B7+B1
          ZR     X1,XLBC1    IF END OF TRAILER WORDS
          ZR     X0,XLBC2    IF NO LOADING WILL OCCUR 
          MI     X1,XLBC2    IF ECS ADDRESS 
          MX3    -6 
          AX1    18          FIELD SIZE TO LOW-ORDER BITS 
          BX2    -X3*X1 
          AX1    6
          SX2    X2-18
          BX3    -X3*X1 
          AX1    6
          NZ     X2,XLBC2    IF SIZE IS WRONG 
          SX2    X3-15
          SX4    X3-30
          IX2    X2*X3
          SX1    X1 
          IX2    X2*X4
          SA4    PO 
          NZ     X2,XLBC2    IF NOT ON INSTRUCTION BOUNDARY 
          SA3    DE 
          SA2    TPGM 
          IX1    X1+X4       REFERENCE ADDRESS
          SX7    X3+B1
          BX6    X0+X1
          IX2    X2+X3
          SA7    A3 
          SA6    X2 
          EQ     XLBC2
  
  
          IDENT              SEGMENT GENERATION - PASS 1. 
          TITLE  SEGMENT GENERATION - PASS 1. 
          SPACE  4,8
**        SYMBOL DEFINITIONS FOR PASS 1.
  
  
 P1       BSS    0           FWA OF PASS 1
 CP       CON    0           PRU OF PROGRAM ON SCRATCH FILE 
 C1       DATA   0LCMM.SUA   CHECK FOR THIS ENTRY TO FORCE *CMM.UNL*
 C2       DATA   0LCMM.UNL   NAME OF UNLOAD PROCESSOR USED BY *SEGRES*
 C3       DATA   0LCMM.SDA   NAME OF DABA MOVING PROCESSOR FOR *SEGRES* 
 C4       DATA   0LCMM.ALF   NAME OF FIXED BLOCK ALLOCATOR FOR *SEGRES* 
 IL       CON    0           INDEX INTO *TREQ2* FOR *LDSET* PROCESSING
 LN       CON    0           HIGHEST LEVEL NUMBER 
 NS       CON    0           NUMBER OF SEGMENTS * 2 
 PL       CON    0           PROGRAM LENGTH DETERMINED SO FAR 
 PR       CON    0           IF THE CURRENT PROG PRESETS INTO BLOCK 
 WC       CON    0           WORD COUNT OF REMAINING WORDS IN TABLE 
 XI       CON    0           INDEX FOR START OF EXTERNAL ENTRIES
          SPACE  4,8
**        PASS 1 PROCESSING.
* 
*              WE ENTER PASS 1 WITH ALL CONTROL CARDS AND *SEGLOAD* 
*         DIRECTIVES CRACKED.  WE WANT TO COMPLETE PASS 1 WITH *TCEL*,
*         *TBLK* AND *TLNK* BUILT AND READY FOR THE FINAL LOAD. 
*         WE FIRST CALL *REQ* TO PROCESS LOADER DIRECTIVES (UP TO 
*         THE *NOGO* OR *EXECUTE*).  WE GET CONTROL WHENEVER *RDR*
*         IS CALLED TO DO A READ.  WE DO THE READ IN PASS 1 TO GET ALL
*         ENTRY POINTS, EXTERNAL REFERENCES AND COMMON BLOCK
*         DEFINITIONS.  WE PUT THE INFORMATION INTO THE TABLES *TLNK*,
*         *TEPT1* AND *TSEG* RESPECIVELY.  AFTER *REQ* RETURNS CONTROL
*         TO *LOADS* WE CALL *SAT* TO SATISFY EXTERNLAS.  ONCE ALL
*         PROGRAMS AND BLOCKS HAVE BEEN ASSIGNED TO A SEGMENT WE
*         CAN DEFINE THE ENTRY POINT ADDRESSES.  NEXT WE CREATE *TBLK*
*         IN THE ORDER IN WHICH WE WANT TO LOAD AND APPEAR IN THE MAP.
*         AFTER INITIALIZING THE BINARY FILE AND PREALLOCATING ECS
*         WE ARE READY FOR PASS 2.
  
  
 PASS1    SA1    L+1
          SX6    P0 
          SX7    ENDS 
          SA6    O+1         FET *O* USES INITIALIZATION FOR BUFFER 
          SA7    O+4
          SX6    X1+IP.LBUF 
          SA6    L+4         RESET FET *L* LIMIT TO USE ENTIRE BUFFER 
          SETFET O,Z1,BINARY      SET UP SCRATCH FILE 
          REWIND O,RCL       REWIND RANDOM SCRATCH FILE 
          MX6    1
          SA1    X2+B1       SET RANDOM BIT IN FET *O*
          LX6    -12
          BX6    X6+X1
          SA6    A1 
          SX6    -B1
          SA6    SEGFLAG     FLAG FOR PASS 1
          RJ     REQ         PROCESS LOADER REQUESTS
          RJ     AUX         ADD UNSATISFIED EXTERNALS TO *TLNK*
          SB7    B0 
          RJ     SAT         SATISFY EXTERNALS
          RJ     PNF         PROCESS PROGRAMS NOT FOUND 
          RJ     USX         PROCESS UNSATISFIED EXTERNALS
          RJ     CMM         CHECK FOR MEMORY MANAGER 
          RJ     DDE         DEFINE DUPLICATE PROGRAM ENTRIES 
          RJ     OEP         ORDER ENTRY POINTS 
          RJ     SAC         SET ALL COMMON 
          RJ     APS         ASSIGN PROGRAMS TO SEGMENTS
          RJ     OEP         ORDER DUPLICATE ENTRY POINTS 
          RJ     AMR         ASSIGN MOVEABLE PROGRAM TO ROOT SEGMENT
          RJ     FCA         FIX COMMON ASSIGNMENTS 
          RJ     FAP         FIX ASSIGNMENTS OF PROGRAMS
          RJ     FLS         FIX LOCAL SAVE BLOCKS
          RJ     FDT         FIND DELINK TABLE LENGTH 
          RJ     AMU=        ACCUMULATE MEMORY USED 
          SX7    B0 
          SA7    TEPT1+1     CLEAR EXTERNAL REFERENCES FROM *TEPT1* 
          RJ     CBT         CREATE BLOCK TABLE (*TBLK*)
          RJ     REP         RELOCATE ENTRY POINTS
          RJ     RET         RELOCATE ERROR TABLE TO INDEX INTO *TBLK*
          RJ     AMU=        ACCUMULATE MEMORY USED 
          SX7    B0 
          SX6    B1 
          SA2    TSEG+1      SAVE NUMBER OF *TSEG* ENTRIES FOR MAP
          SA7    A2          CLEAR *TSEG* 
          SA7    TERR1+1     CLEAR ERROR INDEX TABLE
          SA7    PI          SET PROGRAM INDEX FOR NO PROGRAMS READ YET 
          SA6    SEGFLAG     SET FOR PASS 1 COMPLETE
          AX7    X2,B1
          SA7    TSEGFIN
          SA1    FE 
          NZ     X1,ABEND    IF FATAL ERRORS ABORT LOAD 
          RJ     IBF         INITIALIZE BINARY FILE 
 ECS      IFTEST NE,IP.MECS,0 
          SA2    ECSPA
          ZR     X2,PASS2    IF NO ECS TO ALLOCATE
          MX6    0
          SA6    A2 
          BX1    X2 
          RJ     APS=        ALLOCATE ECS SPACE 
 ECS      ENDIF 
          EQ     PASS2
          TITLE  SEGMENT GENERATION - PASS 1 MAIN ROUTINES. 
 AMR      SPACE  4,10 
**        AMR - ASSIGN MOVEABLE PROGRAM TO ROOT SEGMENT 
* 
*             ALL PROGRAMS WHICH ARE STILL UNASSIGNED ARE ASSIGNED TO 
*         THE ROOT SEGMENT.  *APS* IS CALLED TO DO THE REASSIGNING OF 
*         PROVISIONALLY ASSIGNED PROGRAMS NECESSITATED BY THE FIXING
*         OF THE UNASSIGNED PROGRAMS. 
* 
*         USES   X - 1, 2, 3, 6, 7. 
*                B - 2, 5, 6, 7.
*                A - 1, 2, 3, 6.
*         CALLS  APS. 
  
  
 AMR2     ZR     B5,AMR      IF NO REASSIGNMENTS MADE 
          MX6    0
          SA6    APSA        INITIALIZE *APS* TEMP CELLS
          SA6    A6+B1
          RJ     APS         ASSIGN PROGRAM TO SEGMENT
  
 AMR      PS     0           ENTRY/EXIT 
          SA1    TSEG        FWA OF *TSEG*
          SA3    NS          NUMBER OF SEGMENTS 
          SA2    A1+B1
          MX7    45 
          SB6    X3          (B6) = CURRENT INDEX IN *TSEG* 
          SB7    X2          (B7) = LENGTH OF *TSEG*
          LX7    3
          SB2    B1+B1       (B2) = 2 
          SB5    B0          INITIALIZE REASSIGNMENT COUNT
 AMR1     GE     B6,B7,AMR2  IF TABLE SCAN COMPLETE 
          SA2    X1+B6       GET *TSEG* ENTRY 
          SB6    B6+B2       INCREMENT *TSEG* INDEX 
          SX3    X2 
          LX2    59 
          MI     X2,AMR1     IF COMMON BLOCK
          AX3    3
          NZ     X3,AMR1     IF MODULE ASSIGNED 
          LX2    1
          BX6    X7*X2       CLEAR OWNING SEGMENT INDEX 
          SB5    B5+B1       INCREMENT REASSIGNMENT COUNT 
          SA6    A2 
          EQ     AMR1        LOOP FOR NEXT PROGRAM
 APS      SPACE  4,8
**        APS - ASSIGN PROGRAM TO SEGMENTS. 
* 
*              ALL FIXED PROGRAMS HAVE BEEN ASSIGNED TO A SEGMENT.  WE
*         MUST ASSIGN ALL MOVABLE MODULES TO A SEGMENT AND WE DO THIS 
*         BY TAKING ALL EXTERNAL REFERENCES FROM A PROGRAM, FINDING 
*         THE COMPATIBLE ENTRY POINT AND DECIDING WHETHER THE PROGRAMS
*         SHOULD BE MOVED TO THEIR NEAREST COMMON ANCESTOR (NCA). 
*         THE RULES FOR ASSIGNMENT ARE AS FOLLOWS.  WE ASSUME WE
*         HAVE AN EXTERNAL FROM PROGRAM A1 IN SEGMENT S1 SATISFIED BY 
*         AN ENTRY IN PROGRAM A2 IN SEGMENT S2. 
*         F      MEANS FIXED PROGRAM. 
*         PA     MEANS PROVISIONALLY ASSIGNED.
*         U      MEANS UNASSIGNED.
* 
*         A1     A2          ACTION 
*         F      F           IF S1 AND S2 ARE COMPATIBLE FIXED PROGRAMS 
*                            DO NOTHING ELSE TRY ANOTHER ENTRY POINT
*                            OF THE SAME NAME.  IF NO COMPATIBLE ENTRY
*                            EXISTS THEN CREATE A DUPLICATE COPY TO 
*                            SATISFY THE EXTERNAL.
*         F      PA          ASSIGN A2 TO NCA OF S1 AND S2. 
*         F      U           ASSIGN A2 TO S1. 
*         PA     F           ASSIGN A1 TO NCA OF S1 AND S2 IF S1 AND S2 
*                            ARE INCOMPATIBLE.
*         PA     PA          MOVE A2 TO NCA OF S1 AND S2. 
*         PA     U           ASSIGN A2 TO S1. 
*         U      F           DO NOTHING.
*         U      PA          DO NOTHING.
*         U      U           DO NOTHING.
* 
*              THE ITERATION PROCESS STOPS WHEN NO PROGRAMS ARE 
*         REASSIGNED.  THIS ALGORITHM HAS THE PROPERTY THAT ALL 
*         REFERENCES TO MOVABLE MODULES WILL NOT CAUSE LOADING. 
* 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  SMS=, ELT, CCP, NCA, ADW=, CDE, MCB. 
*         CALLS  SMS=, ELT, CCP, NCA, ADW=, CDE, SEN. 
  
  
 APS      PS                 ENTRY/EXIT 
          SMSG   DBG5 
 APS1     SA1    TEPT1+1
          SA2    APSA 
          SA3    A1-B1
          IX4    X2-X1
          PL     X4,APS11    IF SCAN OF *TEPT1* COMPLETE
          SX6    X2+2 
          IX2    X2+X3
          SA6    A2 
          SA1    X2          *TEPT1* ENTRY
          SA2    X2+B1
          SA3    TSEG 
          LX2    -36
          SB5    X3          (B5) = FWA OF *TSEG* 
          SA5    X2+B5       *TSEG* ENTRY MAKING THIS REFERENCE (A) 
          SX6    X5 
          AX6    3
          SB6    B0          (B6) = FLAG FOR FIXED (0) OR PROV. ASS. (1)
          SA6    APSD 
          PL     X6,APS2     IF A FIXED MODULE
          ZR     X6,APS1     IF CALLING PROGRAM IS UNASSIGNED 
          MX3    -14
          BX6    -X3*X6 
          SB6    B1 
          SA6    A6 
 APS2     RJ     SEN         CHECK FOR SUBSTITUTION 
          MX2    0           FLAG SEARCH ONLY 
          RJ     ELT         SEARCH *TLNK*
 APS3     SA6    APSC 
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,APS1     IF ENTRY IS UNSATISFIED OR OMITTED 
          LX2    -36
          SA1    TSEG        RESTORE *TSEG* FWA 
          SB5    X1 
          SA2    X2+B5       *TSEG* ENTRY FOR DEFINING PROGRAM (B)
          BX4    X2 
          LX4    -1 
          PL     X4,APS4     IF THIS IS PROGRAM ENTRY 
          SX2    X2 
          AX2    3
          SA2    X2+B5       PROGRAM ENTRY (B)
 APS4     SA1    APSD 
          BX0    X2 
          SA0    A2          SAVE ADDRESS OF PROGRAM DEFINITION 
          AX2    3
          MX3    -14
          SB2    X1 
          BX2    -X3*X2 
          SB3    X2 
          SX3    B3-37777B
          ZR     X3,APS5     IF CALLED PROGRAM IS UNASSIGNED
          RJ     CCP         CHECK FOR COMPATIBLE PROGRAMS
          ZR     X6,APS1     IF NO LOADING WILL OCCUR DO NOT MOVE PROGRA
          SB4    X6          SAVE COMPATIBILITY 
 APS5     SX1    B2 
          SX2    B3 
          RJ     NCA         FIND NEAREST COMMON ANCESTOR 
          MX7    14 
          LX7    17 
          ZR     B6,APS8     IF EXTERNAL CAME FROM FIXED MODULE 
          SX3    X0 
          LX6    3
          PL     X3,APS7     IF CALLED PROGRAM IS FIXED 
          BX2    X7*X0       OLD ASSIGNMENTS
          BX0    -X7*X0      REMOVE OLD ASSIGNMENT
          IX3    X2-X6
          BX7    X0+X6
          SA7    A0          ASSIGN PROGRAM TO THEIR NCA
 APS6     SA1    APSB 
          ZR     X3,APS1     IF ASSIGNMENTS ARE STILL THE SAME
          SX6    X1+B1
          SA6    A1 
          EQ     APS1 
  
 APS7     BX3    X7*X5       OLD ASSIGNMENT 
          GE     B4,B0,APS1  IF COMPATIBLE - NO MOVE NECESSARY
          BX7    -X7*X5 
          IX3    X3-X6
          BX6    X7+X6       MOVE (A) TO NCA
          SA6    A5 
          EQ     APS6 
  
 APS8     SX3    X0 
          PL     X3,APS9     IF (B) IS FIXED PROGRAM
          BX3    X7*X0
          LX6    3
          BX7    -X7*X0      MOVE (B) TO NCA
          IX3    X3-X6
          BX6    X6+X7
          SA6    A0          ASSIGN PROGRAM TO THEIR NCA
          EQ     APS6 
  
 APS9     GE     B4,B0,APS1  IF COMPATIBLE CALL BETWEEN FIXED PROGRAMS
          SA2    TLNK 
          SA1    APSC 
          SA3    A2+B1
          SX4    X1+B1
          IX6    X4+X2
          IX3    X4-X3
          SA1    X6 
          PL     X3,APS10    IF END OF *TLNK* - MAKE DUP COPY OF PROG 
          SA3    A1-2 
          BX3    X1-X3
          NZ     X3,APS10    IF NO MORE DUPS FOR THIS ENTRY POINT 
          SA2    A1+B1       NEW DEFINITION 
          SX6    X4+B1       NEW INDEX
          EQ     APS3        TRY NEXT ENTRY POINT DEFINITION IN *TLNK*
  
 APS10    SA1    A0          ASSIGN PROGRAM PROVISIONALLY TO CALLER 
          MX6    1
          SX2    B2 
          LX6    18 
          BX1    -X7*X1 
          LX2    3
          BX1    X6+X1
          BX1    X1+X2
          SA2    A0+B1
          RJ     AET         ADD ENTRY TO *TSEG*
          SA1    TSEG        RESTORE *TSEG* FWA 
          SB5    X1 
          SX6    A0-B5
          SX7    X4-1 
          RJ     CDE         CREATE DUPLICATE ENTRY INFO
          EQ     APS1 
  
 APS11    SA1    APSB 
          NZ     X1,APS12    IF NEW ASSIGNMENTS THIS PASS 
          RJ     MCB         MOVE COMMON BLOCKS 
          SX5    A0 
          ZR     X5,APS      IF NO PROGRAMS MOVED 
 APS12    MX6    0
          SA6    APSA        INITIALIZE FOR NEXT PASS 
          SA6    A6+B1
          EQ     APS1 
  
 APSA     CON    0           CURRENT INDEX IN *TEPT1* 
 APSB     CON    0           NUMBER OF ASSIGNMENTS MADE THIS ITERATION
 APSC     CON    0           INDEX OF DEFINITION OF ENTRY POINT 
 APSD     CON    0           SEGMENT INDEX OF CALLING PROGRAM 
 AUX      SPACE  4,8
**        AUX - ADD UNSATISFIED EXTERNAL TO *TLNK*. 
* 
*              THE UNSATISFIED EXTERNALS OF A SEGMENT LOAD ARE IN 
*         *TEPT1* AND NOT IN *TLNK* SO THIS ROUTINE IS CALLED TO PUT
*         THEM IN *TLNK*.  THIS WILL ALLOW LIBRARY SEARCH ROUTINES TO 
*         SATISFY EXTERNALS.  CALLS *CPRELT* TO ENTER THE NAME
*         AND PROPER FLAGS INTO *TLNK*. 
* 
*         USES   X - 1, 2, 3, 6.
*                B - 5, 6, 7. 
*                A - 1, 2, 3, 6.
*         CALLS  SEN, CPRELT. 
  
  
 AUX      PS                 ENTRY/EXIT 
          SA1    TEPT1
          SA3    AUXA 
          SA2    A1+B1
          SX6    X2 
          SB7    X3          (B7) = CURRENT ENTRY IN *TEPT1*
          SA6    A3 
          SB5    X1          (B5) = FWA OF *TEPT1*
          SB6    X2          (B6) = LENGTH OF *TEPT1* 
 AUX1     EQ     B7,B6,AUX   IF TABLE SCAN COMPLETE 
          SA1    B5+B7       EXTERNAL REFERENCE 
          RJ     CPRELT      ENTER LINK TABLE 
          SB7    B7+2        (B7) = NEXT *TEPT1*
          SA1    TEPT1
          SB5    X1 
          EQ     AUX1        IGNORE WHETHER OR NOT ENTRY WAS FOUND
  
 AUXA     CON    0           INDEX OF NEXT *TEPT1* ENTRY TO TRY 
 CBT      SPACE  4,8
**        CBT - CREATE BLOCK TABLE (*TBLK*).
* 
*              IN THIS ROUTINE WE TRY TO MOVE ALL *TSEG* ENTRIES TO 
*         *TBLK*.  WE MUST ORDER THE BLOCKS AND PROGRAMS IN THE PROPER
*         ORDER SO THAT PASS 2 CAN LOAD THEM EASILY AND SO THE MAP
*         GENERATION IS DONE IN A MANNER SIMILAR TO A RELOCATABLE LOAD. 
*         THIS ROUTINE WILL ASSIGN A PROGRAM ADDRESS TO ALL BLOCKS, 
*         SEGMENTS AND PROGRAMS.  THE *TCEL* TABLE IS GENERATED AT THE
*         SAME TIME AS *TBLK*.  AT THE COMPLETION OF THE MOVE, THE
*         CM AND ECS BLANK COMMON FWA ADDRESSES ARE ADDED TO THE ENTRIES
*         IN *TBLK*.  THE LWA+1 OF CM USED IS ADDED TO THE               LDR0167
*         ROOT SEGMENT ENTRY IN *TCEL*.  WE ALSO ADD BITS TO THE ROOT 
*         SEGMENT ENTRY FOR BLANK COMMON PRESENT, MULTI-LEVEL TREE
*         STRUCTURE, 54 TABLE LOAD AND NEW SEGMENT LOADER BINARY
*         FORMAT (GLOBAL SAVE BLOCKS APPEAR AFTER THE DELINK TABLE
*         INSTEAD OF AT THE END OF THE SEGMENT).
* 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  SMS=, ESD, ADW=, CPA.
  
  
 CBT      PS                 ENTRY/EXIT 
          SMSG   DBG7 
          SA1    NS 
          SX6    X1+1000B    BASE ADDRESS FOR ROOT SEGMENT
          SA6    CBTB        HHA
          SA6    A6+B1       FWA OF LEVEL 
          LX6    24 
          MX7    1
          BX6    X6+X7       ADD UNREFERENCED BIT 
          SA1    TBLK 
          SA6    X1+5        SAVE LENGTH IN ABS ORIGIN BLOCK
 CBT1     SA1    CBTA 
          SA2    TSEG 
          MX4    15 
          IX3    X1+X2
          LX4    18 
          SA3    X3 
          BX6    X4*X3       INDEX OF FATHER
          MX0    0           SET L=0 IN *TCEL* DEFINITION 
          BX7    X6-X4
          SA2    CBTC        FWA OF CURRENT LEVEL 
          ZR     X7,CBT3     IF THIS IS PATRIARCH ON SAME LEVEL 
          ZR     X1,CBT3     IF ROOT SEGMENT
          ZR     X6,CBT6     IF THIS IS FIRST PATRIARCH ON LEVEL
 CBT2     SA2    TCEL 
          AX6    3
          IX3    X2+X6
          SA2    X3          *TCEL* ENTRY FOR FATHER
          SA3    X3+B1
          SX2    X2          FWA OF FATHER
          SX3    X3          LENGTH OF FATHER 
          IX2    X2+X3       LWA+1 OF FATHER = FWA OF THIS SEGMENT
 CBT3     SX6    X2 
          RJ     ESD         ENTER SEGMENT DEFINITIONS
          SA4    CBTB        HHA
          IX5    X1+X2       LWA+1 OF THIS SEGMENT
          IX6    X5-X4
          AX6    60 
          BX4    X6*X4
          BX5    -X6*X5 
          IX6    X4+X5       HHA = MAX(HHA,LWA+1) 
          SA6    A4 
          LX3    18 
          BX5    X2+X3       SECOND WORD OF DEFINITION
          SA4    A4-B1
          BX5    X5+X0       ADD *L* BIT TO DEFINITION
          SA2    TSEG 
          IX6    X4+X2
          SA2    X6 
          SA3    X6+B1
          SX2    X2 
          AX3    24 
          AX2    4
          SX3    X3          LENGTH OF DELINK TABLE 
          MX6    -12
          BX3    -X6*X3 
          LX3    48 
          BX2    -X6*X2      FATHER 
          LX2    18 
          BX1    X1+X3
          BX1    X1+X2
          ADDWRD TCEL,X1
          ADDWRD A2,X5
          SA1    CBTA 
          SA2    NS 
          SX6    X1+2 
          IX3    X6-X2
          SA6    A1 
          MI     X3,CBT1     IF MORE SEGMENT ENTRIES LEFT 
          SA1    TBLK 
          SA2    CBTB        HHA
          SA3    X1+B1       CM // ENTRY
          MX6    -24
          BX6    X6*X3
          AX3    24 
          SX4    X3          LENGTH OF CM //
          ZR     X4,CBT3B    IF NO CM //
          SX2    X2+2        SET FWA CM // AND *HHA* UP BY 2 WORDS
                              TO ACCOMMODATE CMM PROCESSING 
 CBT3B    IX7    X4+X2
          SA7    HHACM       SAVE HHA OF CM LOAD
          BX6    X6+X2
          SB2    X4 
          SA6    A3          ADD *PA* INTO CM // ENTRY
          LX7    36 
          SA4    A3+2 
          SA1    TCEL 
 ECS      IFTEST NE,IP.MECS,0 
          SA3    ECSPA
          SA2    ECSFL
          IX6    X2-X3
          AX6    60 
          BX2    X6*X2
          BX3    -X6*X3 
          BX3    X2+X3       MIN(ECSFL,ECSPA) IN CASE INSUFF. ECS FL
          BX6    X3+X4
          SA6    A4          ADD *PA* TO ECS // 
 ECS      ENDIF 
          SA2    X1+B1
          BX7    X7+X2       ADD HHA OF CM INTO ROOT SEGMENT ENTRY
          SX6    3
          LX6    56-0        *C* AND *N* =1 
          BX7    X7+X6
          ZR     B2,CBT4     IF NO CM BLANK COMMON
          MX6    1
          BX7    X7+X6       *B* = 1
 CBT4     SA1    LN 
          ZR     X1,CBT5     IF NOT A LEVEL STRUCTURE 
          SX6    B1 
          LX6    58-0 
          BX7    X7+X6       *L*=1
 CBT5     SA7    A2          RESET ROOT DEFINITION
          RJ     CPA         COMPLETE PROGRAM ADDRESS FOR GLOBALS 
          EQ     CBT
  
 CBT6     SA3    A3+B1
          AX3    -12
          SA2    A2-B1       HHA
          SX7    X2 
          SA7    A2+B1       SET FWA = HHA
          ZR     X3,CBT3     IF THIS IS SON OF ROOT SEGMENT 
          MX0    1
          LX0    -1 
          EQ     CBT3 
  
 CBTA     CON    0           CURRENT SEGMENT INDEX
 CBTB     CON    0           HHA OF LOAD
 CBTC     CON    0           FWA OF CURRENT LEVEL 
 CMM      SPACE  4,8
**        CMM - CHECK FOR MEMORY MANAGER. 
* 
*            IF ANY CMM ROUTINES ARE INCLUDED IN THE LOAD, *SEGRES* 
*         MUST BE ABLE TO CALL *CMM.ALF* AND *CMM.SDA* IN ORDER 
*         TO ALLOCATE CM AND MOVE ITS TABLES.  IF ANY ENTRY POINTS
*         BEGINNING WITH *CMM.* ARE PRESENT, THEN A *USE* REQUEST 
*         IS ISSUED ON THE ABOVE ENTRY POINTS.
*            ALSO IF *CMM.SUA* IS PRESENT, THE ENTRY POINT *CMM.UNL*
*         IS INCLUDED IN THE SAME MANNER, AS *SEGRES* MUST CALL 
*         IT TO UNLOAD SEGMENTS.
*            SEE ROUTINE *IBF* FOR METHOD OF PASSING THESE ENTRY
*         ADDRESSES TO *SEGRES*.
* 
*         USES   X - 0, 1, 2, 3, 5, 6, 7. 
*                B - 2, 3, 4, 5, 7. 
*                A - 0, 1, 2, 5, 6, 7.
*         CALLS  ELT, EBD, ATS=, USE, SAT, USX, SEN.
  
  
 CMM      PS                 ENTRY/EXIT 
          SA1    C1 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SB7    B1 
          SX2    B0 
          RJ     ELT         LOOK FOR *CMM.SUA* IN TABLE
          ZR     X2,CMM1     IF NOT IN TABLE
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,CMM1     IF OMITTED OR UNSATISFIED
          SA1    C2 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0 
          RJ     ELT         LOOK FOR *CMM.UNL* 
          NZ     X2,CMM1     IF CMM.UNL IN TABLE
          SB7    B7+B1
          ALLOC  TREQ,B1,FRONT
          SA1    C2 
          SB5    X2          (B5) = TABLE FWA 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          BX6    X1 
          SA6    B5          ADD NAME TO *USE* REQUEST
          MX5    1
          RJ     EBD         ENTER BLOCK DEFINITION FOR PROG IN ROOT
 CMM1     SA1    C3 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0 
          RJ     ELT
          MX3    2
          ZR     X2,CMM2     IF NOT IN TABLE
          LX3    -1 
          BX3    X3*X2
          ZR     X3,CMM6     IF SATISFIED ALREADY 
 CMM2     SA1    TLNK 
          NE     B7,B1,CMM5  IF *CMM.SUA* IS IN TABLE FORCE *CMM.SDA* 
          SA2    A1+B1
          SB2    X1          (B2) = FWA OF TABLE
          SB3    B0          (B3) = CURRENT INDEX IN TABLE
          SB4    X2          (B4) = LENGTH OF TABLE 
          SB5    B1+B1       (B5) = 2 
          MX3    2
          LX3    -1 
          MX6    24 
          SA1    C1 
          BX1    X6*X1       *CMM.* 
          LX6    -18
          LX1    -18
 CMM3     GE     B3,B4,CMM   IF NO *CMM.* ENTRY IN *TLNK* 
          SA2    B2+B3       *TLNK* ENTRY 
          SB3    B3+B5
          BX2    X6*X2
          IX2    X1-X2
          ZR     X2,CMM4     IF WE FOUND *CMM.* ENTRY POINT 
          MI     X2,CMM      IF NO *CMM.* ENTRY POINT IN *TLNK* 
          EQ     CMM3 
  
 CMM4     SA2    A2+B1
          BX2    X3*X2
          NZ     X2,CMM3     IF OMITTED OR UNSATISFIED
          SA2    A2-B1       ENTRY NAME AGAIN 
          SX2    X2-3RKIL 
          ZR     X2,CMM3     IF *CMM.KIL*, IGNORE IT
 CMM5     SB7    B7+B1
          ALLOC  TREQ,B1,FRONT
          SA1    C3 
          SB5    X2          (B5) = TABLE FWA 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          BX6    X1 
          SA6    B5          ADD NAME TO *USE* REQUEST
          MX5    1
          RJ     EBD         ENTER BLOCK DEFINITION FOR PROG IN ROOT
 CMM6     SA1    C4          *CMM.ALF*
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0          SEARCH *TLNK* FOR *CMM.ALF*
          RJ     ELT
          ZR     X2,CMM7     IF NOT PRESENT 
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,CMM7     IF *CMM.ALF* IS UNSATISFIED
          AX2    24+12       GET *TSEG* ENTRY 
          SA1    TSEG 
          SB2    X1 
          SA3    B2+X2
          MX6    45          CLEAR OWNING SEGMENT FIELD SO AS TO
          LX6    3            FORCE INTO ROOT SEGMENT 
          BX6    X6*X3
          SA6    A3 
          EQ     CMM8 
  
 CMM7     SB7    B7+B1       ANOTHER WORD TO *USE* REQUEST
          ALLOC  TREQ,B1,FRONT
          SA1    C4          *CMM.ALF*
          SB5    X2 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          BX6    X1 
          SA6    B5          ADD NAME TO *USE* REQUEST
          MX5    1           ENTER BLOCK DEFINITION FOR PROG IN ROOT
          RJ     EBD
 CMM8     EQ     B7,B1,CMM   IF NOTHING TO LOAD 
          ALLOC  TREQ,B1,FRONT                                           LDR0249
          SX3    10000B*CUSE BUILD *USE* REQUEST                         LDR0249
          SX7    B7-B1                                                   LDR0249
          BX7    X7+X3
          LX7    36 
          SA7    X2 
          SB2    B7          LENGTH OF REQUEST                           LDR0249
          SA5    A7 
          SA0    A2 
          MX0    48 
          RJ     USE         PROCESS *USE* REQUEST                       LDR0249
          SA1    TREQ 
          MX3    48 
          SA2    X1 
          LX2    -36
          BX1    -X3*X2 
          SB2    X1+B1       RELEASE *TREQ* SPACE FOR *USE* 
          ALLOC  TREQ,-B2,FRONT 
          SB7    B0          USE GLOBAL LIBRARY SET                      LDR0249
          RJ     SAT         SATISFY EXTERNALS                           LDR0249
          RJ     USX         PROCESS UNSATISFIED EXTERNALS               LDR0249
          EQ     CMM
 DDE      SPACE  4,8
**        DDE - DEFINE DUPLICATE PROGRAM ENTRIES. 
* 
*              WE SCAN THROUGH *TSEG* LOOKING FOR DUPLICATE  PROGRAM
*         ENTRIES CREATED BY OCCURENCES OF THE PROGRAM NAME ON
*         *SEGLOAD* DIRECTIVES.  WE HAVE ALREADY READ ONE COPY OF THE 
*         PROGRAM, WE MUST ADD AN ENTIRELY NEW SET OF ENTRIES TO *TLNK*,
*         *TEPT1* AND *TSEG* SO THAT DUPLICATE COPIES CAN BE
*         MANIPULATED AS SEPARATE PROGRAMS. 
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 4, 5, 6, 7. 
*                A - 1, 2, 3, 4, 6. 
*         CALLS  CDE. 
  
  
 DDE      PS                 ENTRY/EXIT 
          SA2    NS 
          SA3    TSEG 
          SB7    X2+B1       (B7) = CURRENT INDEX OF DEFINITION 
          SA4    A3+B1
          SB2    B1+B1       (B2) = 2 
          SB6    X4          (B6) = LENGTH OF *TSEG*
 DDE1     GE     B7,B6,DDE   IF END OF TABLE
          SA2    X3+B7
          SB7    B7+B2
          PL     X2,DDE1     IF NOT UNDEFINED 
          SA1    A2-B1
          LX1    59-0 
          MI     X1,DDE1     IF NOT A PROGRAM 
          SA2    NS 
          MX7    42+3 
          LX1    0-59 
          SB5    B7-B1
          LX7    3
          SB4    X2          (B4) = CURRENT INDEX FOR SEARCH
 DDE2     GE     B4,B5,DDE1  IF NOT DEFINED AT ALL
          SA2    X3+B4
          BX6    X2-X1
          BX6    X7*X6
          SB4    B4+B2
          NZ     X6,DDE2     IF NOT THE ENTRY WE WANT 
          SA4    A2+B1
          MI     X4,DDE1     IF PROGRAM NOT DEFINED 
          SB7    B7-B2
          BX6    X4 
          SX7    B7-B1
          SA6    X3+B7       SET DEFINITION THE SAME
          SX6    B4-B2
          RJ     CDE         CREATE DUPLICATE ENTRY INFO
          SA3    TSEG 
          SB2    B1+B1
          SA4    A3+B1
          SB7    B7+B2
          SB6    X4 
          EQ     DDE1 
 FAP      SPACE  4,8
**        FAP - FIX PROVISIONALLY ASSIGNED PROGRAMS TO SEGMENTS.
* 
*              PROGRAM ENTRIES IN *TSEG* WITH BIT 17 SET HAVE BEEN
*         PROVISIONALLY ASSIGNED TO THE SEGMENT SPECIFIED BY BITS 
*         3-16.  THEY WILL BE FIXED BY CLEARING BIT 17. 
* 
*         USES   X - 1, 2, 3, 6, 7. 
*                B - 2, 6, 7. 
*                A - 1, 2, 3, 6.
  
  
 FAP      PS                 ENTRY/EXIT 
          SA1    TSEG+1 
          SA2    NS 
          SA3    A1-B1       (X3) = FWA OF *TSEG* 
          SB7    X1          (B7) = LENGTH OF *TSEG*
          MX7    1
          SB6    X2          (B6) = CURRENT INDEX IN *TSEG* 
          LX7    18 
          SB2    B1+B1
 FAP1     GE     B6,B7,FAP   IF TABLE SCAN COMPLETE 
          SA1    X3+B6
          SB6    B6+B2
          SX2    X1 
          LX1    -1 
          MI     X1,FAP1     IF NOT PROGRAM BLOCK 
          LX1    1
          BX6    -X7*X1      CLEAR PROVISIONALLY ASSIGNED BIT 
          SA6    A1 
          EQ     FAP1 
 FLS      SPACE  4,10 
**        FLS - FIX LOCAL SAVE BLOCKS.
* 
*         FOR EACH LOCAL SAVE BLOCK ENTRY IN *TLSB* THE CORRESPONDING 
*         ENTRY IN *TSEG*  IS FOUND.  A SECOND *TSEG* ENTRY IS GENERATED
*         THE ORIGINAL ENTRY IS CHANGED TO POINT TO THE NEW ENTRY AND IT
*         IS FLAGGED AS BEING GLOBAL AND A GLOBAL SAVE BLOCK. 
* 
*         USES   X - 0, 1, 2, 3, 4, 5, 6. 
*                B - 3, 6, 7. 
*                A - 1, 2, 3, 4, 5, 6.
* 
*         CALLS  ADW=.
  
  
 FLS      PS     0           ENTRY/EXIT 
          SA1    TLSB+1      LENGTH OF TLSB 
          ZR     X1,FLS      IF NO LOCAL SAVE BLOCKS
          SA2    TLSB 
          SB6    B0          INDEX INTO *TLSB*
          SA5    X2          (X5) = FIRST ENTRY IN *TLSB* 
          SB7    X1-1        (B7) = LENGTH - 1 OF *TLSB*
          MX0    42 
          SA1    NS 
          SB3    X1          (B3) = INDEX OF NONSEGMENT ENTRIES 
 FLS1     SA1    TSEG         GET *TSEG* ENTRY
          SA1    X1+B3
          SB3    B3+2 
          BX3    X0*X1       EXTRACT NAME 
          BX3    X3-X5       COMPARE NAMES
          NZ     X3,FLS1     IF NOT A MATCH 
          MX3    15          EXTRACT SEGMENT INDEX
          LX3    18 
          BX2    X3*X1
          AX2    3
          SA4    TSEG 
          IX4    X4+X2       GET *TSEG* ENTRY FOR OWNING PROGRAM
          SA4    X4 
          BX4    X3*X4       EXTRACT OWNING SEGMENT INDEX 
          BX1    -X3*X1      MASK OUT OLD SEG INDEX 
          BX1    X1+X4       (X1) = 42/NAME,15/TSEG,2/0,1/1 
          SA5    A1+B1       SECOND WORD OF CURRENT *TSEG* ENTRY
          SA4    TSEG+1      (X4) = *TSEG* LENGTH = INDEX TO NEXT ENTRY 
          MX2    -23
          SX4    X4+B1       POINT TO 2ND WORD OF ENTRY 
          BX5    X5*X2
          SX2    5           SET *V* AND *G* BITS 
          LX2    47-2 
          BX2    X5+X2       (X2) = 2ND WORD OF NEW *TSEG* ENTRY
          BX6    X2+X4       SET POINTER TO DEFINITION ENTRY
          SA6    A5          REPLACE SECOND WORD OF OLD *TSEG* ENTRY
          RJ     AET         ADD ENTRY TO *TSEG*
          SB6    B6+2 
          GE     B6,B7,FLS   IF AT END OF *TLSB*
          SA5    TLSB 
          SA5    X5+B6       (X5) = NEXT ENTRY FROM *TLSB*
          EQ     FLS1 
  
 FCA      SPACE  4,10 
**        FCA - FIX COMMON ASSIGNMENTS. 
* 
*             EACH COMMON BLOCK NAME IN *TCOM* IS MOVED INTO *TSEG* 
*         AS A GLOBAL -SAVE BLOCK RESIDING IN THE SEGMENT DETERMINED
*         BY *MCB*.  AN UNASSIGNED BLOCK WILL BE ASSIGNED TO THE
*         ROOT SEGMENT. 
* 
*         USES   X - 0, 1, 2, 3, 4, 5, 6, 7.
*                B - 3, 4, 5, 6, 7. 
*                A - 1, 2, 3, 6.
*         CALLS  CTAB=, SLG, ADW=.
  
  
 FCA4     SA2    TCOM 
          RJ     CTAB=       CLEAR *TCOM* 
  
 FCA      PS     0           ENTRY/EXIT 
          SA1    TCOM+1 
          SB6    B0 
          SB7    X1          (B7) = LENGTH OF *TCOM*
 FCA1     GE     B6,B7,FCA4  IF END OF TABLE
          SA2    TCOM 
          SA1    X2+B6       GET ENTRY FROM *TCOM*
          SB6    B6+B1
          SX2    X1+
          MI     X2,FCA1     IF GLOBAL BLOCK
          MX0    42 
          BX5    X0*X1       EXTRACT NAME 
          LX1    59-16
          PL     X1,FCA2     IF ASSIGNED
          MX2    0
 FCA2     LX2    3
          SX2    X2+1        SET COMMON BIT 
          BX1    X2+X5       (X1) = 42/NAME,15/TSEG,2/0,1/1 
          MX6    20 
          SX4    5
          LX6    -15
          LX4    47-2        *V* AND *G* BITS 
          BX2    X6+X4       (X2) = 12/0,1/V,1/0,1/G,21/7777776B,24/0 
          RJ     AET         ADD ENTRY TO *TSEG*
          SA1    NS 
          IX3    X1+X2
          SB3    X3          (B3) = FWA OF NONSEGMENT ENTRIES IN *TSEG* 
          IX3    X2+X4
          SB4    X3-1        (B4) = LWA-1 OF *TSEG* 
 FCA3     GE     B3,B4,FCA1  IF END OF *TSEG* 
          SA1    B3          GET *TSEG* ENTRY 
          LX1    59-0 
          SB3    B3+2 
          PL     X1,FCA3     IF NOT COMMON BLOCK
          LX1    58-59       ECS BIT
          MI     X1,FCA3     SKIP IF ECS COMMON BLOCK 
          LX1    0-58 
          BX2    X0*X1       EXTRACT NAME 
          BX3    X2-X5       COMPARE NAMES
          NZ     X3,FCA3     IF NOT A MATCH 
          SX3    5
          SA1    A1+B1       GET WORD TWO OF ENTRY
          BX6    X1+X4       ADD IN DEFINITION INDEX
          LX3    47-2 
          BX6    X6+X3       MERGE IN *V* AND *G* BITS
          SA6    A1          RESTORE WORD 
          MX3    -21
          AX1    24 
          BX2    -X3*X1      EXTRACT LENGTH 
          SX7    X4          (X7) = DEFINITION INDEX
          RJ     SLG         SET LENGTH OF GLOBAL TO MAXIMUM
          EQ     FCA3        LOOP FOR REST OF *TSEG*
 FDT      SPACE  4,8
**        FDT - FIND DELINK TABLE LENGTH. 
* 
*              THE LENGTH OF THE DELINK TABLE IS THE NUMBER OF EXTERNAL 
*         REFERENCES WHICH MAY CAUSE LOADING OF ANOTHER SEGMENT.  FOR 
*         ALL EXTERNAL REFERENCES IN A SEGMENT, FIND THE COMPATIBLE 
*         ENTRY POINT AND DETERMINE IF LOADING WILL OCCUR.  THE LENGTH
*         IS ADDED TO THE SEGMENT DEFINITIONS AT THE FRONT OF *TSEG*. 
* 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - 2, 4, 5, 6, 7. 
*                A - 1, 2, 3, 6.
*         CALLS  SMS=, SEN, FEP.
  
 FDT      PS                 ENTRY/EXIT 
          SMSG   DBG6 
          SA1    TEPT1
          SA2    A1+B1
          SB5    X1+B1       (B5) = FWA+1 OF *TEPT1*
          SB6    X2          (B6) = LENGTH OF *TEPT1* 
          SA1    TSEG 
          SB7    -2          (B7) = CURRENT INDEX IN *TEPT1*
          SB4    X1          (B4) = FWA OF *TSEG* 
 FDT2     SB7    B7+2 
          GE     B7,B6,FDT   IF *TEPT1* SCAN COMPLETE 
          SA2    B5+B7       *TEPT1* ENTRY
          LX2    -36
          SA1    B4+X2       *TSEG* ENTRY FOR DEFINITION
          BX3    X1 
          LX1    59-0 
          PL     X1,FDT3     IF THIS IS A PROGRAM ENTRY 
          SX1    X3 
          AX1    3           INDEX TO PROGRAM ENTRY 
          SA3    B4+X1       PROGRAM ENTRY
 FDT3     SX6    X3 
          AX6    3           INDEX TO SEGMENT ENTRY 
          SB4    X6 
          SA1    A2-B1       EXTERNAL NAME
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SB2    B4          (B2) = SEGMENT INDEX OF CALLING PROGRAM
          RJ     FEP         FIND COMPATIBLE ENTRY
          SA1    TSEG 
          MX4    -12
          SB4    X1          RESET B4 
          ZR     X6,FDT2     IF NO LOADING WILL OCCUR 
          MI     X6,FDT2     IF UNSATISFIED 
          SA1    B5+B7       REFETCH *TEPT1* DEFINITION 
          LX4    24 
          BX4    -X4*X1      NUMBER OF REFERENCES OF THIS EXTERNAL
          SX2    B4+B1
          SA2    X2+B2       *TSEG* DEFINITION
          IX6    X2+X4
          SA6    A2          ADD LENGTH TO LENGTH OF DELINK TABLE 
          EQ     FDT2 
 FPP      SPACE  4,8
**        FPP - FIRST PASS PROCESSOR. 
* 
*              DURING A SEGMENT LOAD THE ROUTINE *RDR* IN QUAL *READ* 
*         TRANSFERS CONTROL TO THIS ROUTINE TO READ THE PROGRAMS. 
*         THE TABLES *TLNK*, *TEPT1* AND *TSEG* ARE BUILT FROM THE
*         PROGRAMS READ.  SOME ERROR DETECTING IS ALSO DONE DURING THE
*         FIRST READ. 
* 
*         ENTRY  *L* = FET INITIATED FOR READ.
*                *O* = FET SETUP FOR WRITE. 
*                (X5) = *T1* FIRST WORD OF RECORD.
*         EXIT   THRU *RDR*.
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ALL TABLE PROCESSORS AND WTO=, RDO=, REQD, CIO=, CFD,
*                ERROR, WNB=. 
  
  
 FPP      SA1    T1 
          SX6    CP 
          SA6    O+6         PUT STATUS WORD IN FET FOR FIRST WRITE 
          MX0    12 
          BX6    X1 
          WRITEO O
          SX6    B0 
          SA6    PN          CLEAR PROGRAM NAME 
          SA6    PR 
          SA1    TEPT1+1
          SA2    TREQ2+1
          SX6    X1 
          SX7    X2 
          SA6    XI          SAVE INDEX FOR FIRST EXTERNAL NAME ENTRY 
          SA7    IL          SAVE LENGTH OF *LDSET* TABLE 
          RJ     PRFX        PROCESS *PRFX* TABLE 
          NZ     X2,FPP2     IF NOT A *PREFIX* TABLE
 FPP1     READO  L
          NZ     X1,FPP6     IF EOR OR EOF WITHOUT *PIDL* TABLE 
          BX5    X6 
          WRITEO O
 FPP2     RJ     LDSET       PROCESS *LDSET* TABLE
          ZR     X2,FPP1     IF *LDSET* TABLE PROCESSED 
          RJ     CAPS        PROCESS *CAPSULE* TABLE
          NZ     X2,FPP2A    IF NOT A *CAPSULE* 
          SA1    REQTYPE     SET REQUEST TYPE FLAG FOR LOADER DIRECTIVE 
          SX7    10B
          BX6    X1 
          SA7    A1 
          SA6    PREVTYPE 
          RJ     REQD        PROCESS LOADER DIRECTIVES
          SA1    PREVTYPE 
          BX6    X1 
          SA6    REQTYPE
          READO  L
          NZ     X1,FPP8     IF EOR OR EOF
          SA6    T1 
          BX5    X6 
          EQ     FPP3A       GO COMPLETE PROGRAM
  
 FPP2A    RJ     PIDL        PROCESS *PIDL* TABLE 
          NZ     X2,FPP4     IF NOT *PIDL* TABLE
          SA1    REQTYPE     SET REQUEST TYPE FLAG FOR LOADER DIRECTIVES
          SX7    10B
          BX6    X1 
          SA7    A1 
          SA6    PREVTYPE 
          RJ     REQD        PROCESS LOADER DIRECTIVES
          SA1    PREVTYPE 
          BX6    X1 
          SA6    REQTYPE
 FPP3     READO  L
          SA6    T1 
          BX5    X6 
          MX0    12 
          NZ     X1,FPP8     IF EOR OR EOF
          BX2    X0*X5       TABLE NUMBER 
          LX2    12 
          BX6    X5 
          LX6    12 
          BX6    X0*X6
          LX6    12 
          SA6    WC          SAVE WC OF TABLE 
          SX1    X2-5600B 
          RJ     XFER        SKIP INTERACTIVE DEBUG TABLES
          SX1    X2-5700B 
          RJ     XFER        SKIP INTERACTIVE DEBUG TABLES
          SX1    X2-4600B 
          RJ     XFER        IF *XFER* TABLE
          RJ     ENTR        IF *ENTR* TABLE
          RJ     PTEXT
          MX3    -9 
          SX6    X5          S IF TABLE IS *TEXT* 
          BX4    X5 
          AX4    18 
          BX3    -X3*X4      R IF TABLE IS *TEXT* 
          RJ     TEXT        IF *TEXT* TABLE
          RJ     XTEXT       IF *XTEXT* TABLE 
          RJ     FILL        IF *FILL* TABLE
          RJ     XFILL       IF *XFILL* TABLE 
          RJ     LINK        IF *LINK* TABLE
          RJ     XLINK       IF *XLINK* TABLE 
          RJ     REPL        IF *REPL* TABLE
          RJ     XREPL       IF *XREPL* TABLE 
          ZR     X2,FPP3     IF TABLE PROCESSED 
 FPP3A    WRITER O,RCL       COMPLETE RECORD
          RJ     CFP         COMPLETE FIRST PASS
          EQ     FPP         START NEXT PROGRAM 
  
 FPP4     BX1    X0*X5       FIRST TWO CHARACTERS OF WORD 
          BX6    X5 
          SA6    T1          SAVE WORD IN *T1*
          LX1    12 
          SX2    X1-5000B 
          SX3    X1-5100B 
          SX6    X1-5300B 
          SX7    X1-5400B 
          IX2    X2*X3
          IX7    X7*X6
          IX6    X7*X2
          NZ     X6,/READ/CKD  IF NOT ABS PROGRAM 
 FPP5     SA1    PN 
          BX7    X1 
          ERROR  304,X7      ---- ABS INPUT IN RELOCATABLE LOAD 
          RECALL O
          RECALL L
          EQ     ABEND
  
 FPP6     WRITER O,RCL       COMPLETE RECORD
          SA2    LSL
          ZR     X2,/READ/RDR1  IF NOT *SLOAD*
          SA3    IL 
          SX6    X3 
          SA6    TREQ2+1     RESET *TREQ2*
          EQ     /READ/RDR1 
  
 FPP7     SA1    PN          PROGRAM NAME 
          BX7    X1 
          ERROR  420,X7      ---- ABS OR NEGATIVE RELOCATION NOT ALLOWE 
          RECALL O
          RECALL L
          EQ     ABEND
  
 FPP8     WRITER O,RCL       COMPLETE RECORD
          RJ     CFP         COMPLETE FIRST PASS
          EQ     /READ/RDR1 
  
 FPP9     WRITER O,RCL       COMPLETE RECORD
          SA1    PREVTYPE 
          BX6    X1 
          SA6    REQTYPE
          READO  L
          NZ     X1,/READ/RDR  IF EOR OR EOF
          BX5    X6 
          SA6    T1 
          EQ     FPP
 IBF      SPACE  4,8
**        IBF - INITIALIZE BINARY FILE. 
* 
*              IF THE BINARY FILE IS NOT ON A RANDOM DEVICE WE USE THE
*         FILE ZZZZZ32 AS THE BINARY FILE.  IF ZZZZZ32 IS USED WE 
*         PRECEDE EACH RECORD BY THE ACTUAL FILE SO THE ROUTINE *CPY* 
*         IN *LOADM* CAN SPOOL THE FILE WHEN WE ARE DONE.  WE INITIALIZE
*         THE BINARY FILE BY FIRST WRITING THE WORD *SEGLOAD.* ON 
*         A SEPARATE RECORD.  NEXT WE PREALLOCATE THE ECS IMAGE IF ECS
*         LABELLED COMMON BLOCKS HAVE BEEN DEFINED BY THIS LOAD.
*              IF *CMM* ROUTINES ARE PRESENT, A WORD IS ADDED TO THE END
*         OF *TCEL* TO PASS THE ADDRESSES OF *CMM.ALF*, *CMM.SDA*, AND
*         *CMM.UNL*.
* 
*         USES   X - 0, 1, 2, 5, 6, 7.
*                B - NONE.
*                A - 1, 2, 6, 7.
*         CALLS  SETFET=, CIO=, WTO=, WSO, WFN, WTW=, SEN.
  
  
 IBF      PS                 ENTRY/EXIT 
          SA1    SEGBBB 
          SX7    B1 
          BX6    X1 
          SA7    DA          STARTING DISK ADDRESS ON BINARY FILE 
          SA6    OF          BINARY FILE NAME 
          SETFET L,OF,BINARY
          OPENNR L,RCL
          SA1    L+1
          PL     X1,IBF1     IF A RANDOM FILE 
          SA2    Z2 
          BX6    X2 
          SA6    OF 
          SA6    CPYF        FLAG FOR SPOOL TO BINARY FILE
          SETFET L,OF,BINARY USE ALTERNATE BINARY FILE
          REWIND L,RCL       REWIND IN CASE FILE EXISTS 
          SA1    SEGBBB 
          BX6    X1 
          WRITEO L
          EQ     IBF1A
  
 IBF1     REWIND L,RCL       REWIND IN CASE RANDOM FILE EXISTS
 IBF1A    SA1    IBFA 
          BX6    X1 
          WRITEO L
          SX1    B1 
          RJ     WSO         WRITE SEGMENT OVERLAY
          SA1    TBLK 
          SA2    X1+3        ECS // DEFINITION
          MX5    -24
          BX5    -X5*X2      ECS BLOCK LENGTH 
          ZR     X5,IBF2A    IF NO ECS IMAGE
          MX6    1
          SA1    L+1
          LX6    -12
          BX6    X6+X1
          SA6    A1          SET RANDOM BIT 
          SX6    EA 
          SA6    L+6         ADDRESS OF DISK ADDRESS TO BE RETURNED 
          RJ     WFN         WRITE FILE NAME IF BINARY FILE NOT ON DISK 
 IBF2     SX6    10B
          IX5    X5-X6
          WRITEW L,IBF,10B   PREALLOCATE ECS IMAGE
          NZ     X5,IBF2     IF MORE TO WRITE 
          SA2    TBLK 
          SA1    X2+3 
          MX6    -24
          BX1    -X6*X1      LENGTH OF ECS IMAGE
          RJ     WSO         WRITE SEGMENT OVERLAY
 IBF2A    SA1    C3 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0 
          RJ     ELT
          ZR     X2,IBF      IF ENTRY NOT IN TABLE DO NOT ADD WORD
          MX3    2
          LX3    -1 
          SX0    X2          ADDRESS OF *CMM.SDA* 
          BX3    X3*X2
          ZR     X3,IBF3     IF SATISFIED 
          MX0    1
          LX0    18          USE 400000B AS ADDRESS 
 IBF3     SA1    C2 
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0 
          RJ     ELT
          SX1    B0 
          ZR     X2,IBF4     IF *CMM.UNL* IS NOT PRESENT
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,IBF4     IF UNSATISFIED 
          SX1    X2          ADDRESS OF *CMM.UNL* 
 IBF4     LX1    18 
          BX0    X1+X0       TWO ADDRESSES
          SA1    C4          *CMM.ALF*
          RJ     SEN         SUBSTITUTE EXTERNAL NAME 
          SX2    B0          FIND ADDRESS 
          RJ     ELT
          MX1    1           USE 400000B IF UNSATISFIED 
          LX1    18 
          ZR     X2,IBF5     IF NOT PRESENT 
          MX3    2
          LX3    -1 
          BX3    X3*X2
          NZ     X3,IBF5     IF UNSATISFIED OR OMITTED
          SX1    X2          ADDRESS OF *CMM.ALF* 
 IBF5     LX1    36 
          BX1    X1+X0       THREE ADDRESSES
          ADDWRD TCEL,X1
          EQ     IBF
  
 IBFA     DATA   0LSEGLOAD. 
 OEP      SPACE  4,8
**        OEP - ORDER DUPLICATE ENTRY POINTS. 
* 
*              ENTRY POINTS ARE ORDERED SO THAT THE ENTRY POINTS IN 
*         FIXED MODULES CLOSEST TO THE ROOT ARE USED FIRST. 
*         THIS ALGORITHM ASSUMES THAT THERE ARE NO UNSATISFIED
*         ENTRIES FOR DUPLICATE ENTRY POINTS. 
* 
*         USES   X - 0, 1, 2, 3, 4, 6, 7. 
*                B - 2, 3, 4, 5, 6, 7.
*                A - 1, 2, 3, 4, 6, 7.
  
  
 OEP      PS                 ENTRY/EXIT 
          SA1    TLNK 
          SB2    B1+B1       (B2) = 2 
          SA2    A1+B1
          SB4    X1          (B4) = FWA OF *TLNK* 
          SB6    -B2         (B6) = CURRENT INDEX IN *TLNK* 
          SB7    X2          (B7) = LENGTH OF *TLNK*
 OEP0     SB5    B7-B2       (B5) = LENGTH - 2 OF *TLNK 
 OEP1     SB6    B6+B2
          GE     B6,B5,OEP   IF AT LAST ENTRY IN *TLNK* 
          SA1    B4+B6
          SA2    A1+B2
          IX3    X1-X2
          NZ     X3,OEP1     IF ENTRY POINTS NOT THE SAME 
          SA4    TSEG 
          MX2    3
          SA3    A1+B1
          LX2    -1 
          SB3    X4          (B3) = FWA OF *TSEG* 
          BX2    X2*X3
          NZ     X2,OEP1     IF UNSATISFIED OR OMITTED
          LX3    -36
          SA2    B3+X3       *TSEG* ENTRY DEFINING THE ENTRY POINT
          BX3    X2 
          LX3    -1 
          PL     X3,OEP2     IF NOT PROGRAM ENTRY 
          SX2    X2 
          AX2    3
          SA2    X2+B3       PROGRAM ENTRY
 OEP2     MX0    -15
          AX2    3
          BX0    -X0*X2      INDEX OF SEGMENT OWNING PROGRAM OR 77777B
          SB5    B6 
          SX6    A2-B3
          SA6    OEPA        SAVE INDEX OF PROGRAM ENTRY IN *TSEG*
 OEP3     SB5    B5+B2
          GE     B5,B7,OEP0  IF END OF *TLNK* - NO MORE DUPS
          SA2    B4+B5
          IX6    X2-X1
          NZ     X6,OEP0     IF NOT DUPS
          SA3    A2+B1
          MX4    2
          LX4    -1 
          BX4    X4*X3
          NZ     X4,OEP3     IF UNSAT OR OMITTED LEAVE AS LAST ENTRY
          LX3    -36
          SA4    B3+X3       *TSEG* ENTRY DEFINING ENTRY POINT
          BX3    X4 
          LX3    -1 
          PL     X3,OEP4     IF PROGRAM ENTRY 
          SX4    X4 
          AX4    3
          SA4    X4+B3       PROGRAM ENTRY
 OEP4     MX6    -15
          AX4    3
          BX6    -X6*X4 
          IX3    X0-X6
          MI     X3,OEP3     IF THIS ENTRY BELONGS TO HIGHER SEGMENT
          SA3    OEPA 
          SX7    A4-B3
          NZ     X3,OEP5     IF NOT FROM SAME SEGMENT 
          IX3    X3-X7
          MI     X3,OEP3     IF THIS PROGRAM DECLARED LATER 
 OEP5     SA3    A1+B1
          SA7    OEPA 
          SA4    A2+B1
          BX0    X6          NEW SEGMENT NUMBER CLOSEST TO ROOT 
          BX7    X3 
          LX6    X4 
          SA7    A4 
          SA6    A3 
          EQ     OEP3        TRY TO FIND ENTRY CLOSEST TO ROOT
  
 OEPA     CON    0           INDEX OF PROGRAM ENTRY IN *TSEG* FOR ENTRY 
 REP      SPACE  4,8
**        REP - RELOCATE ENTRY POINTS.
* 
*              UP TO THIS POINT ENTRY POINT ENTRIES IN *TLNK* HAVE
*         CONTAINED ONLY THE RELOCATION AND NOT THEIR ACTUAL ADDRESS. 
*         WE NOW USE THE *PI* FIELD TO FIND THE *TSEG* PROGRAM OR 
*         BLOCK WHICH DEFINES THIS ENTRY POINT.  SINCE THE BASE ADDRESS 
*         OF THE *TSEG* ENTRY HAS NOW BEEN DEFINED, WE CAN COMPUTE
*         THE ENTRY ADDRESS AND RESET *PI* TO THE *TBLK* PROGRAM
*         ENTRY.  ENTRY POINTS DEFINED BY ABSOLUTE RELOCATION HAVE
*         THEIR *BC* BIT SET, SO WE JUST USE THE RELOCATION AS THE
*         ENTRY ADDRESS.
* 
*         USES   X - 0, 1, 2, 3, 4, 6.
*                B - 2, 3, 4, 5, 6, 7.
*                A - 1, 2, 3, 4, 6. 
  
  
 REP      PS                 ENTRY/EXIT 
          SA1    TLNK 
          SA3    TSEG 
          SA4    TBLK 
          SA2    A1+B1
          SB7    B0          (B7) = CURRENT INDEX INTO *TLNK* 
          SB5    X1+B1       (B5) = FWA+1 OF *TLNK* 
          SB6    X2          (B6) = LENGTH OF *TLNK*
          MX0    -24
          SB2    B1+B1       (B2) = 2 
          SB3    X3          (B3) = FWA OF *TSEG* 
          SB4    X4          (B4) = FWA OF *TBLK* 
 REP1     GE     B7,B6,REP   IF RELOCATION OF *TLNK* COMPLETE 
          MX3    2
          SA2    B5+B7       DEFINITION OF ENTRY POINT
          LX3    -1 
          SB7    B7+B2
          BX6    X3*X2
          NZ     X6,REP1     IF UNDER OMIT CONTROL OR UNSATISFIED 
          LX2    -36
          SA4    X2+B3
          BX1    -X0*X2 
          BX2    X0*X2       REMOVE OLD *PI* AND *BC* BIT 
          LX1    59-20
          BX6    X4 
          AX4    18 
          SX3    X4          INDEX INTO *TBLK* = NEW *PI* 
          LX6    59-0 
          SA4    A4+B1       GET *PA* FROM *TSEG* DEFINITION
          MI     X1,REP4     IF ABS RELOCATION
          PL     X6,REP2     IF PROGRAM ENTRY 
          SX4    X3+B1
          SA3    X4+B4       *TBLK* DEFINITION
          BX4    X3 
 REP2     LX2    36 
          BX4    -X0*X4      *PA* 
          BX1    -X0*X2      *A*
          LX1    -24
          AX1    -24         SIGN EXTEND
          IX4    X4+X1       RELOCATED ADDRESS
          BX1    -X0*X4      REMOVE SIGN EXTENSION
          BX2    X0*X2       REMOVE OLD *PA*
          BX2    X2+X1       ADD RELOCATED ADDRESS TO DEFINITION
          SA1    A4-B1
          MI     X6,REP3     IF NOT PROGRAM DEFINITION
          SX1    X1 
          AX1    4           SEGMENT INDEX/2
          LX1    24 
          LX3    36 
          BX6    X3+X2       COMPLETE DEFINITION
          BX6    X6+X1
          SA6    A2          RESET *TLNK* ENTRY 
          EQ     REP1 
  
 REP3     SX1    X1 
          AX1    3           INDEX INTO PROGRAM ENTRY 
          SA1    X1+B3       *TSEG* PROGRAM DEFINITION
          SX3    X1 
          AX1    18          NEW *PI* 
          LX1    36 
          AX3    4           SEGMENT INDEX/2
          LX3    24 
          BX6    X1+X2       COMPLETE DEFINITION
          BX6    X6+X3
          SA6    A2          RESET *TLNK* ENTRY 
          EQ     REP1 
  
 REP4     SX4    B0          SET *PA* = 0 
          EQ     REP2 
 RET      SPACE  4,8
**        RET - RELOCATE ERROR TABLE TO INDEX INTO *TBLK*.
* 
*              ALL ERRORS ISSUED DURING PASS 1 OF A SEGMENT LOAD HAVE 
*         THE *PI* FIELD IN THE *TERR* TABLE POINT TO THE *TSEG* ENTRY
*         AND NOT THE *TBLK* ENTRY.  IN TABLE *TPGM* THERE ARE INICES OF
*         ALL *TERR* HEADER WORDS.  AT THIS POINT WE WILL CHANGE ALL
*         *PI* FIELDS TO REFERENCE THE CORRECT PROGRAM ENTRY IN *TBLK*. 
* 
* -NOTE-       ERROR 4102 ALSO CONTAINS THE *PI* FIELD IN THE TRAILING
*         WORD SO WE MODIFY THE *PI* FIELD THERE TOO.  IF ANY OTHER 
*         ERRORS HAVE THIS PROPERTY, CODE MUST BE INSERTED TO HANDLE
*         THEM SEPARATELY.
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4, 5.
*                A - 1, 2, 3, 4, 6. 
  
  
 RET      PS                 ENTRY/EXIT 
          SA1    TERR 
          SA3    TERR1
          SB2    B0          (B2) = CURRENT INDEX IN *TERR1*
          SA4    A3+B1
          SB4    X1          (B4) = FWA OF *TERR* 
          MX7    18 
          SB3    X4          (B3) = LENGTH OF *TERR1* 
          SA4    TSEG 
          LX7    -12
          SB5    X4          (B5) = FWA OF *TSEG* 
          MX4    -12
 RET1     GE     B2,B3,RET   IF END OF TABLE
          SA1    X3+B2       *TERR1* ENTRY
          SA2    X1+B4       *TERR* HEADER WORD 
          BX1    X7*X2       *PI* INTO *TSEG* 
          BX6    -X7*X2 
          LX1    -30
          SA1    X1+B5       *TSEG* PROGRAM ENTRY 
          LX1    12 
          BX1    X7*X1       NEW *PI* IN *TBLK* 
          SB2    B2+B1
          BX6    X6+X1
          SA6    A2 
          AX6    18 
          BX6    -X4*X6 
          SX1    X6-4102B 
          NZ     X1,RET1     IF NOT ERROR 4102
          SA2    A2+B1
          MX6    -18
          SA1    X2+B5
          BX6    X6*X2
          AX1    18 
          BX6    X6+X1       CHANGE *PI* IN LOWER 18 BITS TO NEW *PI* 
          SA6    A2 
          EQ     RET1 
 SAC      SPACE  4,10 
**        SAC - SET ALL COMMON
* 
*              IF *ALLCOM* IS SET NONZERO, THIS ROUTINE PICKS UP ALL
*         COMMON BLOCK ENTRIES FROM *TSEG*, EXCEPT FOR BLANK COMMON,
*         AND CALLS *ECD* TO ADD THEM TO *TCOM*.
*              LOCAL SAVE BLOCK ENTRIES (NAME = :ANNNNN)
*         ARE NOT PROCESSED, BECAUSE THEY HAVE BEEN PLACED IN *TLSB*, 
*         AND ALSO PLACING THEM IN *TCOM* WOULD RESULT IN TWO COPIES
*         OF THE BLOCK. 
* 
*         USES   X - 0, 1, 2, 3, 5. 
*                B - 5, 6, 7. 
*                A - 1, 2, 3, 5.
*         CALLS  ECD. 
  
  
 SAC      PS     0           ENTRY/EXIT 
          SA1    ALLCOM 
          ZR     X1,SAC      IF NOT ALL COMMON BLOCKS SPECIFIED 
          SA2    TSEG+1 
          SA3    NS 
          SB6    X2+         (B6) = LENGTH OF *TSEG*
          SB7    X3+         (B7) = STARTING INDEX FOR *TSEG* SEARCH
 SAC1     GE     B7,B6,SAC   IF *TSEG* SEARCH COMPLETE
          SA5    TSEG 
          SA1    X5+B7       GET NAME FROM *TSEG* 
          SB7    B7+2 
          LX1    59-0 
          PL     X1,SAC1     IF NOT COMMON BLOCK
          SA2    A1+1 
          LX1    58-59       POSITION TO ECS BIT
          MI     X1,SAC1     IF ECS COMMON BLOCK
          SA3    BC          NAME FIELD FOR BLANK COMMON
          MX0    1
          LX2    59-45
          LX1    2           RESTORE X1 
          BX2    X0*X2       EXTRACT GLOBAL BIT 
          MX0    42 
          BX3    X3-X1       CHECK IF ENTRY IS FOR BLANK COMMON 
          BX3    X0*X3
          ZR     X3,SAC1     IF BLANK COMMON, DO NOT PROCESS
          LX2    17-59
          SA3    UID         IF LOCAL SAVE, ALREADY IN *TLSB* 
          MX5    12 
          BX3    X3-X1
          BX3    X5*X3
          ZR     X3,SAC1     IF LOCAL SAVE
          BX5    X0*X1       EXTRACT NAME 
          BX5    X5+X2       MERGE IN GLOBAL BIT
          RJ     ECD
          EQ     SAC1        LOOP FOR REST OF *TSEG*
          TITLE  SEGMENT GENERATION - PASS 1 TABLE PROCESSORS.
 CAPS     SPACE  4,8
**        CAPS - PROCESS *CAPSULE* TABLE. 
* 
*              THE *CAPS* ROUTINE PROCESSES A *CAPSULE* BINARY
*         TABLE.  A PROGRAM IS MADE UP OF A SINGLE *CAPSULE* TABLE. 
*         THE *CAPSULE* TABLE CONSISTS OF 5 PARTS; 1) HEADER, 
*         2) CODE IMAGE, 3) ENTRY POINT LIST, 4) EXTERNAL NAME LIST,
*         AND 5) RELOCATION TABLE.  THE NAME OF THE PROGRAM WILL BE 
*         THE CAPSULE NAME FOUND IN THE HEADER. 
* 
*              THE ENTIRE *CAPSULE* TABLE EXCEPT THE HEADER WILL
*         BE WRITTEN TO THE SEGMENT LOADER SCRATCH FILE.  AN ENTRY
*         INTO *TEPT* WILL BE MADE FOR EACH ENTRY POINT NAME IN 
*         THE *CAPSULE* ENTRY POINT LIST.  AN ENTRY INTO *TEPT1*
*         WILL BE MADE FOR EACH EXTERNAL NAME IN THE *CAPSULE*
*         EXTERNAL NAME LIST. 
* 
*              THE PROGRAM IS SKIPPED IF THIS IS A *SLOAD* AND THE
*         PROGRAM BEING READ IS NOT REQUESTED.  THE PROGRAM MAY ALSO
*         BE SKIPPED IF IT IS A DUPLICATE PROGRAM FROM A FILE.  IF
*         UNDER *NOS*, A DUPLICATE FROM A LIBRARY IS ALSO SKIPPED.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X0) = MASK (MX0 12).
*         EXIT   (X2) " 0 IF NOT *CAPSULE* TABLE. 
*                     = 0 IF TABLE PROCESSED. 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ADW=, CPY, CSP, EBD, PDP, RDO=, RPN, SFN=, 
*                SMS=, WTO=.
  
  
 CAPS     PS                 ENTRY/EXIT 
          BX1    X0*X5
          LX1    12 
          SX2    X1-6000B 
          NZ     X2,CAPS     IF NOT *CAPSULE* TABLE 
          BX6    X5 
          SA6    /READ/CAPHDR  SAVE FIRST WORD OF CAPSULE HEADER
          READO  L
          WRITEO O
          SA6    /READ/CAPHDR+1  SAVE SECOND WORD OF CAPSULE HEADER 
          READO  L
          WRITEO O
          BX5    X6          (X5) = CAPSULE NAME
 DB       IFTEST NE,IP.LDBG,0 
          MX1    42 
          BX1    X1*X5
          RJ     SFN=        SPACE FILL NAME
          MX2    42 
          SA1    DBG4+1 
          BX6    X2*X6
          BX1    -X2*X1 
          BX6    X1+X6
          SA6    A1 
          SA3    FI 
          SA1    TLFN 
          IX1    X1+X3
          SA1    X1 
          BX1    X2*X1
          MX6    18 
          SA2    A6+B1
          LX1    -18
          BX6    X6*X2
          BX6    X1+X6
          SA6    A2 
          SMSG   DBG4 
 DB       ENDIF 
          SA2    LSL
          MX3    42 
          ZR     X2,CAPS1    IF NOT *SLOAD* 
  
*         CHECK PROGRAM NAME IN *SLOAD* REQUEST.
  
          SA4    /READ/CAPHDR  *CAPSULE* TABLE LENGTH FIELD 
          SX6    X4-4 
          SA6    WC          SAVE WORD COUNT - 1 REMAINING
          RJ     CSP         CHECK FOR *SLOAD* PROGRAM
  
*         PROCESS PROGRAM NAME
  
 CAPS1    BX1    X3*X5       CAPSULE NAME 
          SA2    PC 
          SA5    /READ/CAPHDR+1 
          SA4    FI 
          BX6    X1 
          SX7    X2+B1
          SA6    PN          SAVE CAPSULE NAME AS PROGRAM NAME
          SA7    A2          SAVE INCREMENTED PROGRAM COUNT 
          LX4    48          (X4) = FILE INDEX FIELD
          SX6    X5-3 
          SA6    PL          SAVE CODE IMAGE LENGTH 
          LX6    24          (X6) = LENGTH FIELD
          BX5    X6+X4       (X5) = 12/FI,24/L,24/0 
          MX3    15 
          LX3    18 
          BX1    X1+X3       (X1) = 42/NAME,15/77777,3/0
          RJ     EBD         ENTER BLOCK DEFINITION INTO *TSEG* 
          SX7    X7-1 
          SA7    PI          SAVE PROGRAM INDEX 
          NZ     X6,CAPS2    IF PROGRAM NAME NOT USED BEFORE
  
*         PROCESS DUPLICATE PROGRAM NAME. 
  
          SA1    /READ/CAPHDR 
          SX6    X1-3 
          SA6    WC          SAVE NO. OF WORDS REMAINING IN *CAPSULE* 
          RJ     PDP         PROCESS DUPLICATE PROGRAM NAME 
 CAPS2    SA1    PN 
          RJ     RPN         REMOVE PROGRAM NAME FROM *TUSEP* 
          SA3    PL 
          BX6    X3 
          SA6    WC          SAVE CODE IMAGE LENGTH FOR COPY
          RJ     CPY         COPY CODE IMAGE TO SCRATCH FILE
  
*         PROCESS ENTRY POINT LIST. 
  
          SA1    /READ/CAPHDR 
          LX1    -36
          MX3    -12
          BX7    -X3*X1 
          SB7    X7          (B7) = NUMBER OF ENTRY POINTS
          SA7    WC          SAVE NO. OF ENTRY POINTS 
 CAPS3    READO  L
          WRITEO O
          MX1    42 
          BX1    X1*X6       (X1) = ENTRY POINT NAME
          SX5    X6-3        (X5) = RELATIVE ADDRESS WITHIN CODE IMAGE
          ADDWRD TEPT,X1     ADD FIRST WORD OF *TEPT* ENTRY 
          SA1    PI 
          LX1    36 
          BX1    X5+X1       (X1) = PI + RELATIVE ADDRESS 
          ADDWRD A2,X1       ADD 2ND WORD OF *TEPT* ENTRY 
          SB7    B7-B1
          NZ     B7,CAPS3    IF LIST NOT EXHAUSTED
  
*         READ REST OF CAPSULE TABLE INTO *TCAPS*.
  
          SA1    /READ/CAPHDR+1 
          SA2    WC          (X2) = NO. OF ENTRY POINTS 
          SX1    X1          (X1) = POINTER TO ENTRY POINT LIST 
          IX6    X1+X2       (X6) = POINTER TO EXTERNAL NAME LIST 
          SA6    A2          *WC* = POINTER TO EXTERNAL NAME LIST 
          SA1    /READ/CAPHDR      TOTAL LENGTH OF CAPSULE TABLE
          SX3    X1 
          IX1    X3-X6       (X1) = NO. OF WORDS TO READ
          SX6    B0          CLEAR *TCAPS*
          SA6    TCAPS+1
          ALLOC  TCAPS,X1 
          SB2    X1          (B2) = NO. OF WORDS TO READ
          SB3    B0          (B3) = INDEX INTO *TCAPS*
          SA0    TCAPS       (A0) = *TCAPS* POINTER 
          SA5    A0          (X5) = FWA OF *TCAPS*
 CAPS4    READO  L
          WRITEO O
          SA6    X5+B3       STORE NEXT CAPSULE WORD IN *TCAPS* 
          SB3    B3+B1
          NE     B3,B2,CAPS4 IF CAPSULE TABLE NOT FINISHED
  
*         PROCESS EXTERNAL NAME LIST. 
  
          SA2    /READ/CAPHDR 
          LX2    -24
          MX0    -12
          BX2    -X0*X2 
          SB2    X2          (B2) = NO. OF EXTERNALS IN LIST
          SB3    B0          (B3) = INDEX INTO *TCAPS*
          SA3    A0          (X3) = FWA OF *TCAPS*
  
*         ADD *TEPT1* ENTRY FOR EACH EXTERNAL IN LIST.
  
 CAPS5    GE     B3,B2,CAPS8 IF EXTERNAL NAME LIST FINISHED 
          SA1    X3+B3       GET NEXT EXTERNAL
          MX2    1
          LX2    18 
          BX4    X2*X1
          AX4    17          (X4) = *W* BIT 
          MX0    -17
          BX5    -X0*X1      (X5) = REF. CHAIN ADDRESS IN CAPSULE 
          MX2    42 
          BX1    X2*X1
          BX1    X1+X4       (X1) = 42/NAME,17/0,1/W
          ADDWRD TEPT1,X1    ADD FIRST WORD OF ENTRY
          SA3    A0          GET *TCAPS* FWA
          SA1    WC 
          IX1    X5-X1       (X1) = CHAIN ADDRESS-EXTERNAL LIST PTR 
          IX2    X1+X3       (X2) = ADDRESS OF REF. CHAIN IN *TCAPS*
          SA2    X2          GET FIRST REF. CHAIN WORD
          LX2    20          POSITION TO FIRST REFERENCE FIELD
          SB5    B1+B1       (B5) = FIELD COUNT WITHIN WORD 
          SB6    B0          (B6) = NO. OF REFERENCES (*SI*)
          MX0    2
 CAPS6    BX1    X0*X2
          ZR     X1,CAPS7    IF END OF CHAIN
          SB6    B6+B1
          LX2    20          POSITION TO NEXT REFERENCE 
          SB5    B5-B1
          NZ     B5,CAPS6    IF WORD NOT DONE 
          SB5    3
          SA2    A2+B1       GET NEXT REF. CHAIN WORD 
          EQ     CAPS6
  
 CAPS7    SA1    PI 
          LX1    36 
          SX2    B6 
          LX2    24 
          BX1    X1+X2       (X1) = 6/0,18/PI,12/SI,24/0
          ADDWRD TEPT1,X1    ADD SECOND WORD OF TEPT1 ENTRY 
          SA3    A0          GET FWA OF *TCAPS* 
          SB3    B3+B1
          EQ     CAPS5       GO PROCESS NEXT EXTERNAL 
  
 CAPS8    MX2    0           (X2) = 0 IF TABLE PROCESSED
          EQ     CAPS 
 ENTR     SPACE  4,8
**        ENTR - PROCESS *ENTR* TABLE.
* 
*              WE SAVE ALL ENTRY POINTS IN TABLE *TEPT*.  *CPR* WILL
*         MOVE THEM TO *TLNK*.  THE *PI* FIELD CONTAINS THE INDEX INTO
*         *TSEG* OF THE PROGRAM OR BLOCK DEFINING THE ENTRY POINTS
*         RELOCATION.  THE ADDRESS FIELD CONTAINS THE RELOCATION WHICH
*         WILL NOT  BE RELOACTED UNTIL *REP* IS CALLED.  ENTRY POINTS 
*         DEFINED BY ABSOLUTE RELOCATION HAVE THE *BC* BIT SET AND
*         *PI* POINTS TO THE PROGRAM ENTRY IN *TSEG*.  ENTRY POINTS 
*         DEFINED BY NEGATIVE PROGRAM RELOCATION ARE NOT ALLOWED. 
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X0) = MASK (MX0 12).
*                (X2) = TABLE NUMBER. 
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                B - NONE.
*                A - 1, 2, 6. 
*         CALLS  ADW=, RDO=, WTO=.
  
  
 ENTR     PS                 ENTRY/EXIT 
          SX1    X2-3600B 
          NZ     X1,ENTR     IF NOT *ENTR* TABLE
          BX6    X5 
          WRITEO O
 ENTR1    SA1    WC 
          SX6    X1-2 
          MX2    0
          MI     X6,ENTR     IF TABLE EXHAUSTED 
          SA6    A1 
          READO  L
          WRITEO O
          MX1    42 
          BX1    X1*X6       ENTRY NAME 
          ADDWRD TEPT,X1
          READO  L
          WRITEO O
          BX5    X6 
          MX2    9
          LX2    9+18 
          BX2    X2*X5       R
          LX2    -18
          SA1    TRLB 
          IX3    X1+X2
          SX1    X2-2 
          ZR     X1,FPP7     IF NEGATIVE PROGRAM RELOCATION 
          SX1    B0 
          ZR     X2,ENTR4    IF ABS RELOCATION
 ENTR2    SX6    X5          CM ADDRESS 
          SA2    X3          *TLRB* ENTRY 
          PL     X2,ENTR3    IF CM BLOCK
          LX5    3
          AX5    -21
          BX6    X5 
 ENTR3    AX2    -24
          MX4    -17
          BX7    -X4*X2      PI 
          MX4    -24
          BX6    -X4*X6 
          LX7    36 
          BX6    X6+X1       ADD *BC* BIT 
          BX1    X6+X7
          ADDWRD TEPT,X1     ADD WORD TO TABLE
          EQ     ENTR1
  
 ENTR4    SX1    B1 
          LX1    56 
          EQ     ENTR2
 FILL     SPACE  4,8
**        FILL - PROCESS *FILL* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X0) = MASK (MX0 12).
*                (X2) = TABLE NUMBER. 
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 5, 6.
*                B - NONE.
*                A - 2, 6.
*         CALLS  CPL, RDO=, WTO=. 
  
  
 FILL     PS                 ENTRY/EXIT 
          SX1    X2-4200B 
          NZ     X1,FILL     IF NOT *FILL* TABLE
          BX6    X5 
          WRITEO O
 FILL1    SA2    WC 
          ZR     X2,FILL     IF TABLE COMPLETE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          BX5    X6 
          MX2    9
          LX2    -3 
          PL     X5,FILL2    IF HEADER BYTE 
          BX1    X2*X5       R
          LX1    12 
          BX6    X5 
          AX6    30 
          SX6    X6 
          RJ     CPL         CHECK PROGRAM LENGTH 
 FILL2    LX5    30 
          PL     X5,FILL1    IF HEADER BYTE 
          BX1    X2*X5
          LX1    12 
          AX5    30 
          SX6    X5          A
          RJ     CPL         CHECK PROGRAM LENGTH 
          EQ     FILL1
 LDSET    SPACE  4,8
**        LDSET - PROCESS LDSET TABLE.
* 
*              ALL *LDSET* REQUESTS ARE ADDED INTO *TREQ2* TO BE
*         PROCESSED WHEN WE ARE SURE THIS PROGRAM IS NOT TO BE SKIPPED
*         (*SLOAD* REQUEST).
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES    X - 1, 2, 5, 6. 
*                B - NONE.
*                A - 2, 6.
*         CALLS  ADW=, RDO=, WTO=.
  
  
 LDSET    PS                 ENTRY/EXIT 
          BX1    X0*X5
          LX1    12 
          SX2    X1-7000B 
          NZ     X2,LDSET    IF NOT *LDSET* TABLE 
          LX5    12 
          BX6    X0*X5
          LX6    12 
          SA6    WC          WC 
 LDSET1   SA2    WC 
          ZR     X2,LDSET    IF TABLE COMPLETE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          ADDWRD TREQ2,X6    SAVE *LDSET* TABLE DIRECTIVES
          EQ     LDSET1 
 LINK     SPACE  4,8
**        LINK - PROCESS *LINK* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
*         WE ALSO SAVE ALL EXTERNAL REFERENCES IN *TEPT1* ALONG WITH
*         A COUNT OF THE NUMBER OF TIMES EACH EXTERNAL IS USED. 
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X0) = MASK (MX0 12).
*                (X2) = TABLE NUMBER. 
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 0, 1, 2, 5, 6, 7.
*                B - NONE.
*                A - 1, 2, 6, 7.
*         CALLS  FER, RDO=, WTO=. 
  
  
 LINK     PS                 ENTRY/EXIT 
          SX1    X2-4400B 
          NZ     X1,LINK     IF NOT *LINK* TABLE
          MX0    30 
          BX6    X5 
          WRITEO O
 LINK1    SA2    WC 
          ZR     X2,LINK     IF END OF TABLE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          BX5    X6 
          MI     X6,LINK2    IF NOT ENTRY POINT NAME
          BX1    X5 
          RJ     FER         FIND EXTERNAL NAME 
          EQ     LINK1
  
 LINK2    BX1    X0*X5
          LX5    30 
          ZR     X1,LINK1    IF END OF TRAILER BYTES
          BX5    X0*X5
          LX1    30 
          SX6    X1          A
          AX1    18 
          MX2    -9 
          BX1    -X2*X1      R
          RJ     CPL         CHECK PROGRAM LENGTH 
          SA2    A0 
          SX7    B1 
          LX7    24 
          IX7    X7+X2
          SA7    A2          INCREMENT REFERENCE COUNT
          ZR     X5,LINK1    IF END OF TRAILING BYTES 
          NG     X5,LINK2    IF ANOTHER TRAILER BYTE
          BX0    X5          SAVE HALF OF NAME
          SA2    WC 
          ZR     X2,LINK     IF END OF TABLE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          BX5    X6 
          MX2    30          MASK TO GET REST OF NAME + W BIT 
          BX1    X2*X5
          LX1    -30
          BX1    X0+X1
          MX0    30 
          LX5    30 
          BX5    X0*X5
          RJ     FER         FIND EXTERNAL NAME IN TABLE
          EQ     LINK2       PROCESS TRAILER BYTES
 PIDL     SPACE  4,8
**        PIDL - *PIDL* TABLE PROCESSOR.
* 
*              WE FIRST CHECK TO SEE IF THE PROGRAM BEING READ IS 
*         FROM A *LOAD* REQUEST OR A PROGRAM ON A *SLOAD* REQUEST.
*         IF NOT WE SKIP THE REMAINDER OF THE PROGRAM.  WE ALSO CHECK 
*         FOR DUPLICATE PROGRAMS READ.  THE PROGRAM MAY BE SKIPPED OR 
*         LOADED DEPENDING ON WHETHER THE PROGRAM WAS READ FROM A 
*         LIBRARY OR FROM A LOAD FILE OR WHETHER IT WAS READ ON A 
*         *NOS* OR *NOS/BE* OPERATING SYSTEM.  WE NEXT BUILD THE TABLE
*         *TRLB* AND ADD ENTRIES INTO *TSEG* FOR EVERY BLOCK SPECIFIED
*         IN THE *PIDL* TABLE.  BLANK COMMON ENTRIES IN THE *PIDL*
*         TABLE MUST ALSO SET THE LENGTH IN THE *TBLK* TABLE ENTRY TO 
*         THE MAXIMUM LENGTH DEFINED SO FAR.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X0) = MASK (MX0 12) 
*         EXIT   (X2) " 0 IF NOT *PIDL* TABLE.
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ADW=, CDD=, CSP, EBD, PDP, RDO=, RPN, SFN=,
*                SLG, SMS=, WTO=. 
  
  
 PIDL     PS                 ENTRY/EXIT 
          SX7    B1 
          SA7    LKR         SET FLAG FOR RELOCATABLE LOAD
          BX1    X0*X5
          LX1    12 
          SX2    X1-3400B 
          NZ     X2,PIDL     IF NOT *PIDL* TABLE
          LX5    12 
          BX6    X0*X5
          LX6    12 
          SX6    X6-2        SKIP PROGRAM NAME
          SA6    WC          WORD COUNT 
          READO  L
          WRITEO O
          BX5    X6 
 DB       IFTEST NE,IP.LDBG,0 
          MX1    42 
          BX1    X1*X5
          RJ     SFN=        SPACE  FILL NAME 
          MX2    42 
          SA1    DBG4+1 
          BX6    X2*X6
          BX1    -X2*X1 
          BX6    X1+X6
          SA6    A1          ADD PROGRAM NAME TO MESSAGE
          SA3    FI 
          SA1    TLFN 
          IX1    X1+X3
          SA1    X1 
          BX1    X2*X1
          MX6    18 
          SA2    A6+B1
          LX1    -18
          BX6    X6*X2
          BX6    X1+X6
          SA6    A2          ADD FILE NAME TO MESSAGE 
          SMSG   DBG4 
 DB       ENDIF 
          SA2    LSL
          MX3    42 
          ZR     X2,PIDL3    IF NOT *SLOAD* 
  
*         CHECK PROGRAM NAME IN *SLOAD* REQUEST.
  
          RJ     CSP         CHECK FOR *SLOAD* PROGRAM
  
*         PROCESS PROGRAM NAME. 
  
 PIDL3    BX1    X3*X5       NAME 
          SA2    PC          INCREMENT PROGRAM COUNT
          SA4    FI 
          BX6    X1 
          SX7    X2+B1
          SA6    PN          SAVE PROGRAM NAME
          SA7    A2 
          LX4    48 
          SX6    X5          LENGTH 
          SA6    PL 
          LX6    24 
          BX5    X6+X4       FILE INDEX + LENGTH
          MX3    15 
          LX3    18 
          BX1    X1+X3       MAKE A MOVABLE MODULE
          RJ     EBD         ENTER BLOCK DEFINITION 
          SX7    X7-1 
          SA7    PI          SAVE PROGRAM INDEX 
          NZ     X6,PIDL4    IF PROGRAM NAME NOT USED BEFORE
          RJ     PDP         PROCESS DUPLICATE PROGRAM NAME 
 PIDL4    SX6    B0 
          SA6    TRLB+1      CLEAR *TRLB* 
          SA1    PN          PROGRAM NAME 
          RJ     RPN         REMOVE NAME FROM *TUSEP* 
          SA1    PI 
          LX1    36 
          ADDWRD TRLB,X1
          ADDWRD A2,X1       PROGRAM RELOCATION 
          ADDWRD A2,X1       NEGATIVE PROGRAM RELOCATION
  
*         PROCESS CM LABELLED COMMON BLOCKS.
  
 PIDL5    SA1    WC 
          SX6    X1-1 
          MX2    0
          SA6    A1 
          NG     X1,PIDL     IF TABLE COMPLETE
          READO  L
          WRITEO O
          BX5    X6 
          MX6    23 
          SA2    TSEG+1 
          SX1    X5 
          LX2    36 
          LX6    -1 
          BX1    -X6*X1 
          BX1    X1+X2       T BIT + DI 
          ADDWRD TRLB,X1
          MX7    42 
          SA2    PI 
          BX1    X7*X5       NAME 
          LX2    3
          SX7    B1          T=1
          BX7    X2+X7       TSEG INDEX + T BIT 
          LX1    6
          SX5    X5          LENGTH + E BIT 
          SX2    X1-1R
          LX1    -6 
          ZR     X2,PIDL12   IF BLANK COMMON
          ZR     X1,PIDL15   IF LOCAL ECS BLOCK 
          PL     X5,PIDL5A   IF CM BLOCK
          MX6    -17
          SX2    B1+B1       E=1
          BX5    -X6*X5 
          BX7    X2+X7
          LX5    3           LENGTH 
          EQ     PIDL6
  
 PIDL5A   SA2    LSBN 
          IX2    X1-X2
          NZ     X2,PIDL6    IF NOT LOCAL SAVE
          SA1    /READ/UNAME
          MX2    42 
          SX6    X1+B1       INCREMENT UNIQUE NAME COUNT
          SA6    A1 
          MX6    -30
          SA2    UID
          BX1    -X6*X1 
          LX1    18 
          BX1    X1+X2       :ANNNNN
          BX7    X1+X7
          SA7    T2 
          ADDWRD TLSB,X1     ADD UNIQUE NAME TO *TLSB*
          SA4    PN 
          ADDWRD A2,X4       ADD CORRESPONDING PROGRAM NAME TO *TLSB* 
          SA1    T2          (X1) = UNIQUE NAME 
          SX7    X1 
 PIDL6    BX1    X1+X7       FIRST WORD OF ENTRY
          LX5    24 
          RJ     EBD         ENTER BLOCK DEFINITION 
          NZ     X6,PIDL16   IF BLOCK DEFINITION IS NEW 
          LX5    12 
          MX0    3
          BX0    X0*X5       SAVE V, Q, G BITS
          LX0    24 
          BX0    X0+X2       ADD NEW LENGTH 
          LX0    24 
          LX5    2
          MI     X5,PIDL7    IF GLOBAL BLOCK
          LX5    -14
          SX7    X5          USE INDEX OF EQUATED BLOCK IF ANY
 PIDL7    SA4    A5-B1
          BX0    X0+X7
          RJ     SLG         SET LENGTH OF GLOBAL TO MAX
          MX3    15 
          LX3    18 
          BX1    -X3*X4      NAME AND S,T,E BITS
          SA3    PI 
          LX3    3
          BX1    X1+X3       ADD PROGRAM INDEX
          BX2    X0          (X2) = 2ND WORD OF ENTRY 
          RJ     AET         ADD ENTRY TO *TSEG*
          EQ     PIDL5
  
  
*         PROCESS BLANK COMMON. 
  
 PIDL12   SA2    TBLK 
          SA2    X2+B1       GET *TBLK* ENTRY 
          BX1    X1+X7
          PL     X5,PIDL13   IF CM BLOCK
          SX7    B1+B1       E=1
          BX1    X7+X1
          MX6    -17
          BX5    -X6*X5      LENGTH/10B 
          LX5    3
          SA2    A2+2        GET ECS // ENTRY 
 PIDL13   MX6    24 
          LX6    -12
          BX4    X6*X2       OLD // LENGTH
          LX4    -24
          BX2    -X6*X2      REMOVE OLD LENGTH
          IX6    X5-X4
          AX6    60 
          BX4    X6*X4
          BX6    -X6*X5 
          BX6    X4+X6       MAX(OLD LENGTH,NEW LENGTH) 
          LX6    24 
          MX7    1
          BX6    X6+X2
          BX6    -X7*X6      CLEAR R=1
          SA6    A2          RESET *TBLK* ENTRY 
 PIDL14   LX5    24          (X2) = 2ND WORD OF ENTRY 
          BX2    X5 
          RJ     AET         ADD ENTRY TO *TSEG*
          EQ     PIDL5
  
*         PROCESS LOCAL ECS BLOCKS. 
  
 PIDL15   SA1    /READ/UNAME
          MX2    -17
          SX6    X1+B1
          BX5    -X2*X5      LENGTH/10B 
          SA6    A1          INCREMENT UNIQUE NAME COUNT
          SX6    100000D     FAKE OUT CDD TO STOP ZERO SUPPRESSION
          IX1    X1+X6       THE EXTRA 100000 GETS CHOPPED OFF BELOW
          RJ     CDD=        FORM DECIMAL NAME
          MX1    -30
          SA2    UD 
          BX1    -X1*X6 
          LX1    18 
          BX1    X1+X2       '?NNNNN
          SX3    3           E=1, T=1 
          SA4    PI 
          LX4    3
          BX1    X1+X3
          BX1    X1+X4
          LX5    3
          EQ     PIDL14      ADD ENTRY TO *TSEG*
  
 PIDL16   SA3    TRLB 
          SX1    X7-1        *PI* 
          SA4    A3+B1
          LX1    36 
          IX4    X3+X4
          MX3    1
          SA4    X4-1        CHANGE LAST *TRLB* ENTRY 
          BX6    X3*X4
          BX6    X6+X1       *T* BIT + *PI* 
          SA6    A4 
          LX5    14 
          MI     X5,PIDL17   IF GLOBAL BLOCK
          LX5    -14
          SX7    X5          INDEX+1 OF EQUATED BLOCK IF ANY
 PIDL17   RJ     SLG         SET MAX LENGTH OF GLOBAL 
          EQ     PIDL5
 PRFX     SPACE  4,8
**        PRFX - PROCESS *PRFX* TABLE.
* 
*              WE SAVE THE PROGRAM NAME AND SKIP THE REMAINING TABLE. 
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES    X - 1, 2, 5, 6. 
*                B - 6. 
*                A - 6. 
*         CALLS  RDO=, WTO=, CPY. 
  
  
 PRFX     PS                 ENTRY/EXIT 
          BX1    X0*X5
          LX1    12 
          SX2    X1-7700B 
          NZ     X2,PRFX     IF NOT *PRFX* TABLE
          LX5    12 
          BX6    X0*X5
          LX6    12 
          SX6    X6-1 
          SA6    WC 
          READO  L
          WRITEO O
          SA6    PN          SAVE NAME IN CASE ITS ABS
          RJ     CPY         COPY REMAINING TABLE 
          MX2    0
          EQ     PRFX 
 PTEXT    SPACE  4,10 
**        PTEXT - PROCESS PTEXT TABLE.
* 
*             WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK 
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 0, 1, 2, 3, 4, 5, 6, 7.
*                B - 2. 
*                A - 2. 
*         CALLS  PFE, CPL, RD0=, WD0=.
  
  
 PTEXT    PS     0           ENTRY/EXIT 
          SX1    X2-3500B 
          NZ     X1,PTEXT    IF NOT *PTEXT* TABLE 
          BX6    X5 
          WRITEO O
 PTEXT1   SA2    WC 
          ZR     X2,PTEXT    IF ZERO LENGTH TABLE 
          READO  L
          WRITEO O
          BX5    X6 
          AX6    35 
          SX1    B1 
          BX6    X1*X6       EXTRACT REPLICATION INDICATOR
          SB2    X6+B1       ACCOUNT FOR HEADER WORD
          ZR     X6,PTEXT3   IF NOT REPLICATED
          READO  L
          WRITEO O
 PTEXT3   RJ     PFE         *PTEXT* FIELD EXTRACTION 
          SB3    X1          (B3) = NUMBER OF TEXT WORDS
          SX1    A0          (X1) = RELOCATION BASE 
          RJ     CPL         CHECK PROGRAM LENGTH 
          SA2    WC 
          SX6    B2+B3       CHANGE IN WORD COUNT 
          IX6    X2-X6
          SA6    A2          NEW WORD COUNT 
 PTEXT4   READO  L           COPY TEXT WORDS
          WRITEO O
          SB3    B3-B1
          NZ     B3,PTEXT4   IF MORE WORDS TO COPY
          EQ     PTEXT1 
 REPL     SPACE  4,8
**        REPL - PROCESS *REPL* OR *XREPL* TABLE. 
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) " 0 IF *REPL* TABLE.
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 5, 6.
*                B - NONE.
*                A - 1, 2, 6. 
*         CALLS  CPL, RRP, WTO=.
  
  
 REPL     PS                 ENTRY/EXIT 
          SX1    X2-4300B 
          NZ     X1,REPL     IF NOT *REPL*  TABLE 
          BX6    X5 
          WRITEO O
 REPL1    SA2    WC 
          ZR     X2,REPL     IF NO MORE DESCRIPTORS 
          SX6    X2-2 
          SA6    A2 
          RJ     RRP         READ REPLICATION PAIRS 
          ZR     X2,FPP7     IF SR IS ABS RELOCATION
          SX2    X2-2 
          ZR     X2,FPP7     IF SR IS NEGATIVE PROGRAM RELOCATION 
          SX5    X5-1        C-1
          IX5    X5*X4       K(C-1) 
          IX6    X5+X6       D+K(C-1) 
          IX6    X6+X3       B+D+K(C-1) = LWA+1 OF REPLICATION
          RJ     CPL         CHECK PROGRAM LENGTH 
          EQ     REPL1
 TEXT     SPACE  4,8
**        TEXT - PROCESS *TEXT* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X6) = S = RELATIVE ADDRESS. 
*                (X3) = R = RELOCATION. 
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 3, 6.
*                B - NONE.
*                A - 1, 2.
*         CALLS  CPL, CPY, WTO=.
  
  
 TEXT     PS                 ENTRY/EXIT 
          SX1    X2-4000B 
          NZ     X1,TEXT     IF NOT *TEXT* TABLE
          SA2    WC 
          BX1    X3          R
          SX3    X2-1 
          AX3    4           (WC-1)/16
          SX3    X3+B1       (WC-1)/16+1
          IX3    X2-X3       WC-((WC-1)/16+1) 
          IX6    X6+X3       S+LENGTH OF TEXT BLOCK 
          RJ     CPL         CHECK PROGRAM LENGTH 
          BX6    X5 
          WRITEO O
          RJ     CPY         COPY REMAINING TABLE 
          MX2    0
          EQ     TEXT 
 XFER     SPACE  4,8
**        XFER - PROCESS *XFER*, *SYMBOL* AND *LINE* TABLES.
* 
*              *XFER* TABLES ARE SKIPPED IN PASS 1.  INTERACTIVE
*         DEBUG CANNOT BE ACTIVE ON A SEGMENT LOAD SO THE DEBUG TABLES
*         ARE ALSO SKIPPED. 
* 
*         ENTRY  (X1) = 0 IF A *XFER*, *SYMBOL* OR *LINE* TABLE.
*                (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 6. 
*                B - NONE.
*                A - 1. 
*         CALLS  CPY, WTO=. 
  
  
 XFER     PS                 ENTRY/EXIT 
          NZ     X1,XFER     IF NOT *XFER*, *SYMBOL* OR *LINE* TABLE
          BX6    X5 
          WRITEO O
          RJ     CPY         COPY REMAINING INFO
          MX2    0
          EQ     XFER        IGNORED TRANSFER NAME
 XFILL    SPACE  4,8
**        XFILL - PROCESS *XFILL* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 3, 6.
*                B - NONE.
*                A - 1, 2, 6. 
*         CALLS  CPL, RDO=,WTO=.
  
  
 XFILL    PS                 ENTRY/EXIT 
          SX1    X2-4100B 
          NZ     X1,XFILL    IF NOT *XFILL* TABLE 
          BX6    X5 
          WRITEO O
 XFILL1   SA2    WC 
          ZR     X2,XFILL    IF TABLE COMPLETE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          MX1    -9 
          BX1    -X1*X6 
          AX6    30 
          MX3    -21
          BX6    -X3*X6 
          RJ     CPL         CHECK PROGRAM LENGTH 
          EQ     XFILL1 
 XLINK    SPACE  4,8
**        XLINK - PROCESS *XLINK* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
*         WE ALSO SAVE ALL EXTERNAL REFERENCES IN *TEPT1* ALONG WITH
*         A COUNT OF THE NUMBER OF TIMES EACH EXTERNAL IS USED. 
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 3, 5, 6, 7.
*                B - NONE.
*                A - 1, 2, 6, 7.
*         CALLS  CPL, FER, RDO=, WTO=.
  
  
 XLINK    PS                 ENTRY/EXIT 
          SX1    X2-4500B 
          NZ     X1,XLINK    IF NOT *XLINK* TABLE 
          BX6    X5 
          WRITEO O
 XLINK1   SA2    WC 
          ZR     X2,XLINK    IF TABLE COMPLETE
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          BX1    X6 
          LX5    X6 
          RJ     FER         FIND EXTERNAL NAME IN TABLE
 XLINK2   SA2    WC 
          ZR     X2,XLINK    IF WC EXHAUSTED
          SX6    X2-1 
          SA6    A2 
          READO  L
          WRITEO O
          ZR     X6,XLINK1   IF END OF BLOCK
          MX1    -9 
          BX5    X6 
          BX1    -X1*X6      R
          AX5    24 
          MX2    -6 
          BX2    -X2*X5      POS
          AX5    30 
          MX6    -21
          BX6    -X6*X5      A
          RJ     CPL         CHECK PROGRAM LENGTH 
          SX3    X2-15
          SX4    X2-30
          IX2    X2*X3
          IX2    X2*X4
          NZ     X2,XLINK2   IF NOT ON AN INSTRUCTION BOUNDARY
          SA1    A0 
          SX7    B1 
          LX7    24 
          IX7    X7+X1
          SA7    A1          INCREMENT REFERENCE COUNT
          EQ     XLINK2      GET NEXT TRAILER BYTE
 XREPL    SPACE  4,8
**        XREPL - PROCESS *XREPL* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 0, 1, 2. 
*                B - NONE.
*                A - NONE.
*         CALLS  REPL.
  
  
 XREPL    PS                 ENTRY/EXIT 
          SX1    X2-4700B 
          NZ     X1,XREPL    IF NOT *XREPL* TABLE 
          SX2    4300B
          SX0    B0          *XREPL* FLAG 
          RJ     REPL        PROCESS *XREPL* TABLE
          EQ     XREPL
 XTEXT    SPACE  4,8
**        XTEXT - PROCESS *XTEXT* TABLE.
* 
*              WE MUST COMPUTE THE MAXIMUM LENGTH OF THE PROGRAM BLOCK
*         AND CHECK FOR ABSOLUTE OR NEGATIVE PROGRAM RELOCATION.
* 
*         ENTRY  (X5) = TABLE HEADER WORD.
*                (X2) = TABLE NUMBER. 
*                (X0) = MASK (MX0 12).
*                *WC* = WORD COUNT FOR THIS TABLE.
*         EXIT   (X2) = 0 IF TABLE PROCESSED. 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - NONE.
*                A - NONE.
*         CALLS  TEXT.
  
  
 XTEXT    PS                 ENTRY/EXIT 
          SX1    X2-3700B 
          NZ     X1,XTEXT    IF NOT *XTEXT* TABLE 
          BX2    X5 
          MX4    -24
          MX3    -9 
          BX6    -X4*X5      S
          AX2    24 
          BX3    -X3*X2      R
          SX2    4000B
          RJ     TEXT        PROCESS *XTEXT* TABLE
          EQ     XTEXT
          TITLE  SEGMENT GENERATION - PASS 1 SUBROUTINES. 
 AET      SPACE  4,8
**        AET - ADD ENTRY TO *TSEG* TABLE.
* 
*              THIS ROUTINE ADDS A 2-WORD ENTRY TO *TSEG*, AFTER
*         CHECKING THAT THE TABLE WILL NOT EXCEED ITS MAXIMUM 
*         ALLOWABLE LENGTH, WHICH IS DEFINED BY THE SYMBOL *TSEGMAX*. 
* 
*         IF THE MAXIMUM LENGTH IS EXCEEDED, A *CAT* DIAGNOSTIC 
*         IS ISSUED.
* 
*         ENTRY  (X1) = WORD 0 OF ENTRY TO BE ADDED.
*                (X2) = WORD 1 OF ENTRY TO BE ADDED.
*         EXIT   ALL REGISTERS FROM 2ND CALL TO ADW=. 
*                TWO WORDS ADDED TO *TSEG*. 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - NONE.
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  ADW=.
  
  
 AET      PS                 ENTRY / EXIT 
          BX6    X2          SAVE WORD 1
          SA6    AETSV
          SA3    TSEG+1      CHECK *TSEG* LENGTH
          SX3    X3-TSEGMAX  CHECK IF ALREADY AT MAXIMUM SIZE 
          PL     X3,AET1     IF MAXIMUM WOULD BE EXCEEDED 
          ADDWRD  A3-B1,X1   ADD WORD 0 TO *TSEG* 
          SA1    AETSV
          ADDWRD  A2,X1      ADD WORD 1 
          EQ     AET         RETURN 
  
 AET1     ERROR  CAT,AETERR  ---- SEG+PROG+BLOCK TOTAL EXCEEDED 
  
 AETERR   DATA   C* SEG+PROG+BLOCK TOTAL GT "TSEGMX"* 
 AETSV    CON    0           SAVE AREA
 CCP      SPACE  4,8
**        CCP - CHECK FOR COMPATIBLE PROGRAMS.
* 
*              THIS ROUTINE CHECKS TO SEE IF TWO SEGMENTS ARE 
*         COMPATIBLE.  THIS ROUTINE IS USED WHEN THE SEGMENT
*         DEFINITIONS ARE STILL IN *TSEG*.  IF *TBLK* AND *TCEL*
*         HAVE BEEN CREATED THE USE *CCS* TO CHECK COMPATIBILITY. 
* 
*         ENTRY  (B2) = INDEX OF SEGMENT CONTAINING CALL. 
*                (B3) = INDEX OF SEGMENT CONTAINING CALLED PROGRAM. 
*         EXIT   (X6) < 0 IF CALL IS INCOMPATIBLE.
*                     = 0 IF NO LOAD ON CALL. 
*                     > 0 IF LOADING WILL PROBABLY OCCUR (X6=B3). 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - NONE.
*                A - 1, 2, 3. 
  
  
 CCP      PS                 ENTRY/EXIT 
          SA3    TSEG 
          MX6    0
          SX3    X3+B1
          SA1    X3+B2
          SA2    X3+B3
          AX1    -12
          AX2    -12
          ZR     B3,CCP      IF CALLED PROGRAM IN ROOT
          EQ     B2,B3,CCP   IF PROGRAMS ARE IN SAME SEGMENT
          IX2    X1-X2
          SX6    B3 
          NZ     X2,CCP      IF PROGRAMS ARE ON DIFFERENT LEVELS
          SA1    TSEG 
          SX3    B3 
          SX4    B2 
          LT     B2,B3,CCP1  IF CALLING PROGRAM CLOSER TO ROOT
          SX3    B2 
          SX4    B3 
          MX6    0           FLAG FOR NO LOADING
 CCP1     IX2    X1+X3
          SA2    X2          SEE IF (X4) IS ANCESTOR OF (X3)
          MX3    -13
          AX2    3
          BX3    -X3*X2      FATHER = 2 * INDEX OF ANCESTOR 
          IX2    X3-X4
          ZR     X2,CCP      IF ONE IS ANCESTOR OF THE OTHER
          SX2    X3-17777B
          NZ     X2,CCP2     IF WE DID NOT HIT A PATRIARCH
          SA2    A2+B1
          SX3    B0 
          AX2    -12
          NZ     X2,CCP3     IF NOT A SON OF THE ROOT SEGMENT 
          ZR     X4,CCP      IF ONE IS ANCESTOR OF THE ROOT SEGMENT 
 CCP2     IX2    X3-X4
          PL     X2,CCP1     IF WE HAVE NOT REACHED ANCESTOR YET
 CCP3     MX6    59          INCOMPATIBLE CALL
          EQ     CCP
 CDB      SPACE  4,8
**        CDB - CHECK FOR DUPLICATE BLOCK.
* 
*              WHEN A BLOCK DEFINITION IS BEING ADDED TO *TBLK* THIS
*         ROUTINE MAKES SURE ONLY ONE COPY OF THE SAME BLOCK IS PRESENT 
*         IN ANY ONE SEGMENT. OTHER COPIES OF THE SAME BLOCK WILL 
*         CONTAIN THE INDEX INTO *TBLK* OF WHERE THE ONE COPY EXISTS. 
*         THIS IS SO WE CAN RELOCATE ENTRY POINTS AFTER *TBLK* HAS BEEN 
*         FORMED. 
* 
*         ENTRY  (B2) = - CURRENT SEGMENT INDEX.
*                (B3) = LENGTH OF *TSEG*. 
*                (B4) = 2.
*                (B5) = INDEX IN *TSEG* OF WHERE TO START SEARCH. 
*                (B6) = 1 IF WE ARE TO FIND MAX LENGTH OF ECS BLOCK.
*                (X1) = BLOCK NAME + TYPE BITS. 
*                (X5) = DEFINITION OF BLOCK.
*         EXIT   (X5) = DEFINITION UPDATED TO HAVE MAX LENGTH.
*         USES   X - 2, 3, 5, 7.
*                B - 5. 
*                A - 2, 3, 7. 
  
  
 CDB      PS                 ENTRY/EXIT 
 CDB0     SA2    TSEG        (X2) = FWA OF *TSEG* 
          MX7    42+3 
          LX7    3
 CDB1     GE     B5,B3,CDB   IF END OF TABLE
          SA3    X2+B5
          SB5    B5+B4
          BX3    X3-X1
          BX3    X7*X3
          NZ     X3,CDB1     IF BLOCK NAME AND TYPE DO NOT MATCH
          SA3    A3+B1
          NZ     B6,CDB2     IF WE MUST FIND MAX LENGTH OF ECS BLOCKS 
          SA3    A3-B1
          MX7    -18
          BX3    -X7*X3 
          AX3    3
          IX3    X2+X3
          SA3    X3          PROGRAM ENTRY DEFINING THIS BLOCK
          BX3    -X7*X3 
          AX3    3
          SX3    X3+B2
          NZ     X3,CDB0     IF NOT IN CURRENT SEGMENT
          SX2    X2-2 
          SA3    X2+B5
          SA2    TBLK+1 
          LX2    18 
          BX7    -X7*X3      SET *TBLK* INDEX INTO *TSEG* NAME
          BX7    X7+X2
          SA7    A3 
          MX7    1
          SA3    A3+B1
          BX7    X7+X3       FLAG DUP ENTRIES AS UNREFERENCED 
          MI     X3,CDB0     IF BLOCK ALREADY UNREFERENCED
          SA7    A3 
 CDB2     MX7    21 
          LX7    -15
          BX3    X7*X3       LENGTH OF THIS BLOCK 
          BX2    X7*X5       OLD LENGTH 
          BX5    -X7*X5      UPDATE DEFINITION WITH MAX LENGTH OF BLOCK 
          IX7    X2-X3
          AX7    60 
          BX2    -X7*X2 
          BX3    X7*X3
          IX3    X2+X3       MAX(OLD LENGTH,NEW LENGTH) 
          BX5    X3+X5
          EQ     CDB0 
 CDE      SPACE  4,8
**        CDE - CREATE DUPLICATE PROGRAM ENTRY INFORMATION. 
* 
*              WHEN A PROGRAM WE HAVE READ MUST APPEAR IN MORE THAN 
*         ONE PLACE IN THE TREE STRUCTURE, THIS ROUTINE IS CALLED TO
*         FORM TWO DIFFERENT PROGRAMS.  THE ADDITION IS MADE IN THREE 
*         PARTS.  WE FIRST ADD ALL BLOCKS DEFINED IN THE *PIDL* TABLE 
*         OF THE PROGRAM TO *TSEG* AND MAKE THIS POINT TO THE NEW 
*         PROGRAM ENTRY.  NEXT ADD ALLL ENTRY POINTS DEFINED BY THIS
*         PROGRAM TO *TLNK*.  WE DO NOT ISSUE ANY WARNING MESSAGE 
*         FOR DUPLICATE ENTRY POINTS BECAUSE IT IS REALLY THE SAME ENTRY
*         IN THE SAME PROGRAM.  LAST WE ADD ALL EXTERNAL REFERENCES 
*         MADE BY THE PROGRAM TO *TEPT1*. 
* 
*         ENTRY  (X6) = INDEX OF DEFINED PROGRAM TO BE DUPLICATED.
*                (X7) = INDEX OF DUPLICATE ENTRY IN *TSEG*. 
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 3, 4, 5, 6. 
*                A - 1, 2, 3, 4, 5, 6, 7. 
*         CALLS  ADW=, ATS=, MVE=.
  
  
 CDE      PS                 ENTRY/EXIT 
          SA7    CDEA 
          SA1    NS 
          BX6    -X6
          SB3    X6          (B3) = - INDEX OF PROG TO BE DUPLICATED
          SA2    TSEG 
          SB5    X1          (B5) = CURRENT INDEX IN *TSEG* 
          SA3    A2+B1
          SB2    B1+B1       (B2) = 2 
          SB6    X3          (B6) = LENGTH OF *TSEG*
          SB4    X3          (B4) = INDEX OF DUPLICATED BLOCKS
  
*         SEARCH *TSEG* TO ADD BLOCKS FROM DUPLICATED PROGRAM.
  
 CDE1     GE     B5,B6,CDE2  IF END OF TABLE
          SA1    X2+B5
          SB5    B5+B2
          LX1    59-0 
          PL     X1,CDE1     IF PROGRAM ENTRY 
          MX3    -15
          LX1    -2 
          BX6    -X3*X1 
          SX6    X6+B3
          NZ     X6,CDE1     IF NOT FROM PROG TO BE DUPED 
          SA4    CDEA 
          BX1    X3*X1
          BX1    X1+X4
          LX1    3
          RJ     AET         ADD *TSEG* ENTRY (DUMMY 2ND WORD)
          SX1    B5-B2
          IX1    X1+X2
          SA1    X1+B1       USE SAME DEFINITION
          BX6    X1          STORE OVER 2ND WORD OF ENTRY JUST ADDED
          SA6    X3 
          EQ     CDE1 
  
*         SEARCH *TLNK* TO ADD DUPLICATE ENTRY POINTS.
  
 CDE2     SA3    TLNK 
          SB5    B0          (B5) = CURRENT INDEX IN *TLNK* 
          SA4    A3+B1
          SX5    X3+B1       (X5) = FWA+1 OF *TLNK* 
          SB6    X4          (B6) = LENGTH OF *TLNK*
 CDE3     GE     B5,B6,CDE7  IF END OF TABLE
          SA1    X5+B5       ENTRY POINT DEFINITION 
          SB5    B5+B2
          LX1    -36
          SX6    X1+B3
          ZR     X6,CDE6     IF PROGRAM DEFINES ENTRY POINT 
          SX2    X1 
          SA4    TSEG 
          IX2    X2+X4
          SA2    X2 
          SX3    X2 
          BX6    X2          *TSEG* ENTRY DEFINING ENTRY POINT
          AX3    3
          LX6    59-0 
          SX3    X3+B3
          PL     X6,CDE3     IF A PROGRAM ENTRY - NOT THE RIGHT ONE 
          NZ     X3,CDE3     IF FROM WRONG PROGRAM
          MX7    42+3 
          SB6    B4-B2
          LX7    3
 CDE4     SB6    B6+B2       FIND DUPLICATE BLOCK DEFINING DUP ENTRY
          SA3    X4+B6
          BX3    X3-X2
          BX3    X7*X3
          NZ     X3,CDE4     IF NOT THE RIGHT BLOCK 
          SX4    B6 
 CDE5     MX6    42 
          BX6    X6*X1
          BX5    X6+X4
          LX5    36 
          ALLOC  TLNK,2,FRONT 
          BX3    X2          NEW FWA
          IX2    X2+X1       OLD FWA
          SX1    B5          LENGTH OF MOVE 
          MOVE   X1,X2,X3 
          SA3    TLNK 
          BX6    X5 
          SX5    X3+B1
          SA6    X5+B5       ADD NEW DEFINITION TO *TLNK* 
          SB5    B5+B2       SKIP ENTRY JUST ADDED
          SA4    A3+B1
          SB6    X4 
          EQ     CDE3 
  
 CDE6     SA4    CDEA 
          EQ     CDE5 
  
*         SEARCH *TEPT1* FOR EXTERNAL REFERENCES FOR DUPLICATE PROGRAM. 
  
 CDE7     SA3    TEPT1
          SB5    B0          (B5) = CURRENT INDEX IN *TEPT1*
          SA4    A3+B1
          SX3    X3+B1       (X3) = FWA+1 OF *TEPT1*
          SB6    X4          (B6) = LENGTH OF *TEPT1* 
 CDE8     GE     B5,B6,CDE   IF END OF TABLE
          SA1    X3+B5
          LX1    -36
          SX2    X1+B3
          SB5    B5+B2
          NZ     X2,CDE8     IF EXTERNAL FROM ANOTHER PROGRAM 
          SA5    CDEA 
          LX1    12 
          MX2    -12
          LX5    36 
          BX2    -X2*X1      NUMBER OF REFS FOR THIS EXTERNAL 
          LX2    24 
          BX5    X5+X2
          SA1    A1-B1
          ADDWRD TEPT1,X1 
          ADDWRD A2,X5
          SX3    X2+B1
          EQ     CDE8 
  
 CDEA     CON    0           INDEX OF NEW DUPLICATE PROGRAM ENTRY.
 CFP      SPACE  4,8
**        CFP - COMPLETE FIRST PASS OF PROGRAM. 
* 
*              AFTER A PROGRAM HAS BEEN READ, WE TAKE THE LENGTH OF THE 
*         PROGRAM AND ADD IT TO ITS ENTRY IN *TSEG*.  WE ALSO ADD THE 
*         DISK ADDRESS TO THE PROGRAM ENTRY BECAUSE IT WAS NOT AVAILABLE
*         UNTIL NOW.
* 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - NONE.
*                A - 1, 2, 4, 6.
  
  
 CFP      PS                 ENTRY/EXIT 
          SA1    PI 
          SA2    TSEG 
          IX3    X1+X2
          SA4    X3+B1
          SA1    PL          PROGRAM LENGTH 
          MX2    -21
          LX2    24 
          LX1    24 
          BX6    X2*X4
          SA2    CP 
          BX6    X6+X1       ADD LENGTH OF PROGRAM ENTRY
          BX6    X6+X2       ADD DISK ADDRESS OF PROGRAM ON SCRATCH FILE
          SA6    A4 
          EQ     CFP
 CPA      SPACE  4,8
**        CPA - COMPLETE PROGRAM ADDRESS FOR GLOBAL AND EQUAL BLOCKS. 
* 
*              AFTER THE TABLE *TBLK* HAS BEEN CREATED THE ENTRIES
*         FOR GLOBAL AND EQUAL BLOCKS IN *TBLK*, WHICH DO NOT DEFINE
*         THE BLOCK, MUST BE UPDATED TO CONTAIN THE FWA AND LENGTH
*         OF THE BLOCK.  THIS WILL GIVE THE SAME FWA AND LENGTH FOR 
*         ALL COPIES OF THE GLOBAL OR EQUAL BLOCK IN THE MAP. 
* 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - 2, 3, 4, 5, 6. 
*                A - 1, 2, 3, 4, 6. 
  
  
 CPA      PS                 ENTRY/EXIT 
          SA1    TSEG 
          SA3    NS 
          SA2    A1+B1
          SB2    B1+B1       (B2) = 2 
          SB3    X1          (B3) = FWA OF *TSEG* 
          SB4    X2          (B4) = LENGTH OF *TSEG*
          SB5    X3          (B5) = CURRENT INDEX INTO *TSEG* 
          SA4    TBLK 
          SB6    X4          (B6) = FWA OF *TBLK* 
 CPA1     GE     B5,B4,CPA   IF *TSEG* SCAN COMPLETE
          SA1    B3+B5       *TSEG* ENTRY 
          SB5    B5+B2
          LX1    59-0 
          PL     X1,CPA1     IF PROGRAM ENTRY 
          LX1    0-2
          MI     X1,CPA1     IF SEGMENT ENTRY 
          MX3    3
          SA2    A1+B1
          LX3    -12
          MI     X2,CPA1     IF BLOCK NOT REFERENCED
          BX3    X3*X2
          ZR     X3,CPA1     IF NOT EQUAL OR GLOBAL BLOCK 
          SX6    X2 
          ZR     X6,CPA1     IF DEFINITION OF GLOBAL
          SX6    X2-1 
          AX2    24 
          SX2    X2 
          MI     X2,CPA1     IF GLOBAL BLOCK NOT FOUND
          LX1    2-17 
          SA4    X6+B3       *TSEG* DEFINITION OF GLOBAL
          AX4    18 
          SX4    X4+B1
          SX3    X1+B1
          SA4    X4+B6       *TBLK* DEFINITION
          BX6    X4 
          SA6    X3+B6
          EQ     CPA1 
 CPL      SPACE  4,8
**        CPL - CHECK PROGRAM LENGTH. 
* 
*              THIS ROUTINE CHECKS TO SEE IF ABSOLUTE OR NEGATIVE 
*         PROGRAM RELOCATION IS USED.  IF SO A FATAL ERROR IS ISSUED AND
*         LOADING STOPS.  IF THE RELOCATION IS PROGRAM RELOCATION WE
*         SET THE PROGRAM LENGTH TO THE MAXIMUM OF THAT DECLARED AND
*         AMOUNT USED.  IF THE RELOCATION IS WITH RESPECT TO A COMMON 
*         BLOCK, FLAG THE BLOCK AS PRESET BY THE PROGRAM FOR FUTURE 
*         MODS TO USE.
* 
*         ENTRY  (X1) = RELOCATION. 
*                (X6) = LWA+1 OF THIS LOAD. 
*         EXIT   (X1) = RELOCATION - 2 IF COMMON BLOCK RELOCATION.
*         USES   X - 1, 3, 4, 6.
*                B - NONE.
*                A - 3, 4, 6. 
  
  
 CPL      PS                 ENTRY/EXIT 
          ZR     X1,FPP7     IF ABS RELOCATION
          SX1    X1-2 
          ZR     X1,FPP7     IF NEGATIVE PROGRAM RELOCATION 
          PL     X1,CPL1     IF NOT PROGRAM RELOCATION
          SA4    PL          PROGRAM LENGTH SO FAR
          IX3    X6-X4
          AX3    60 
          BX6    -X3*X6 
          BX4    X3*X4
          BX6    X4+X6       MAX(PL,NEW LWA+1)
          SA6    A4 
          EQ     CPL
  
 CPL1     SA4    TRLB 
          IX3    X4+X1
          SA3    X3+2        GET *TRLB* ENTRY FOR THIS COMMON BLOCK 
          MI     X3,CPL      IF BLOCK IS ECS BLOCK
          AX3    -24
          SX3    X3          DI = INDEX INTO *TSEG* 
          SA4    TSEG 
          MX6    1
          IX3    X3+X4
          LX6    24 
          SA4    X3+B1       *TSEG* DEFINITION
          BX6    X6+X4       SET P=1 FOR BLOCK PRESET BY PROGRAM
          SA6    A4 
          EQ     CPL
 CPY      SPACE  4,8
**        CPY - COPY REMAINING TABLE TO SCRATCH FILE. 
* 
*              THIS ROUTINE READS *WC* WORDS AND COPIES THEM TO 
*         THE SCRATCH FILE. 
* 
*         ENTRY  *WC* = WORD COUNT. 
*         USES   X - 1, 3, 6. 
*                B - 7. 
*                A - 1, 3, 6. 
*         CALLS  RDW=, WTW=.
  
  
 CPY      PS                 ENTRY/EXIT 
 CPY1     SA1    WC 
          ZR     X1,CPY      IF COPY COMPLETE 
          SX6    X1-20B 
          MI     X6,CPY2     IF LESS THAN BUFFER FULL 
          SA6    A1 
          READW  L,CPYA,20B 
          WRITEW O,CPYA,20B 
          EQ     CPY1 
  
 CPY2     SB7    X1 
          READW  L,CPYA,B7
          SA3    WC 
          WRITEW O,CPYA,X3
          EQ     CPY
  
 CPYA     BSS    20B
 CSP      SPACE  4,8
**        CSP - CHECK FOR *SLOAD* PROGRAM.
* 
*              CHECK IF THE PROGRAM BEING READ IS A PROGRAM ON A
*         *SLOAD* REQUEST.  IF NOT, SKIP THE REST OF THE PROGRAM. 
*         OTHERWISE, DECREMENT THE NUMBER OF *SLOAD* PROGRAMS TO
*         BE READ AND FLAG THE PROGRAM AS FOUND IN THE *SLOAD*
*         REQUEST TABLE.
* 
*         ENTRY  *WC* = NUMBER OF WORDS - 1 REMAINING IN TABLE. 
*                (X5) = PROGRAM NAME. 
*                (X3) = MASK (MX3 42).
*         EXIT   (X5) = PROGRAM NAME IF NOT SKIPPED.
*                RETURN TO *RDR* IF PROGRAM SKIPPED AND EOR OR EOF. 
*                          *FPP* IF PROGRAM SKIPPED AND NOT EOR OR EOF. 
*         USES   X - 1, 2, 4, 6, 7. 
*                B - NONE.
*                A - 1, 2, 4, 6, 7. 
*         CALLS  SKP, CIO=. 
  
  
 CSP      PS                 ENTRY/EXIT 
          SA4    TREQ 
          SA2    X4 
          SX1    B1 
          LX2    24 
          SA4    X4+B1       (A4) = FWA-1 OF PROGRAM NAMES
          MX7    -12
          BX7    -X7*X2      (X7) = NUMBER OF NAMES 
 CSP1     SA4    A4+B1
          IX7    X7-X1
          BX2    X4-X5
          BX2    X3*X2
          ZR     X2,CSP2     IF NAME FOUND IN *SLOAD* REQUEST 
          NZ     X7,CSP1     IF LIST NOT EXHAUSED 
          SA1    WC 
          SX5    X1+B1       SKIP REMAINDER OF TABLE
          WRITER O,RCL       COMPLETE RECORD
          RJ     /READ/SKP   SKIP TO NEXT BINARY
          SA2    IL 
          SX7    X2 
          SA7    TREQ2+1     RESET *LDSET* TABLE LENGTH 
          NZ     X1,/READ/RDR  IF EOR OR EOF
          EQ     FPP         START READ OF NEXT PROGRAM 
  
 CSP2     SA2    SLNP        DECREMENT NUMBER OF PROGRAMS 
          IX7    X2-X1
          SA7    A2 
          BX6    X4+X1
          SA6    A4          FLAG *SLOAD* ENTRY AS FOUND
          EQ     CSP
 EBD      SPACE  4,8
**        EBD - ENTER BLOCK DEFINITION. 
* 
*               THIS ROUTINE ADDS A BLOCK NAME AND DEFINITION TO THE
*         TABLE *TSEG*, PROVIDED THE NAME IS NOT ALREADY IN THE TABLE.
* 
*         ENTRY  (X1) = 42/NAME,15/TSEG,1/S,1/E,1/T 
*                       TSEG = INDEX OF SEGMENT OR PROGRAM OWNING BLOCK.
*                       E = 0 IF CM BLOCK.
*                         = 1 IF ECS BLOCK. 
*                       T = 0 IF PROGRAM BLOCK. 
*                         = 1 IF COMMON BLOCK.
*                (X5) = NEW DEFINITION. 
*         EXIT   (X7) = INDEX OF DEFINITION.
*                (X5) = DEFINITION. 
*                (A5) = ADDRESS OF DEFINITION.
*                (X6) = 0 IF BLOCK PREVIOUSLY DEFINED, AND
*                (X2) = NEW LENGTH. 
*         USES   X - 2, 3, 4, 5, 6, 7.
*                B - 2, 3, 4, 5.
*                A - 2, 3, 4, 5, 6. 
*         CALLS  ADW=.
  
  
 EBD2     SA2    A3-B1
          PL     X2,EBD4     IF DEFINED EARILER 
          LX6    -1 
          PL     X6,EBD3     IF A PROGRAM BLOCK 
          LX6    1
          SA6    A2-B1       ADD NEW FIRST WORD ENTRY FOR COMMON BLOCKS 
 EBD3     MX3    3
          SX6    X2          SAVE INDEX OF EQUATED BLOCK
          LX3    47-59
          BX3    X3*X2       SAVE *V*, *Q* AND *G* BITS 
          MX2    -21
          BX5    X5+X3
          BX5    X6+X5
          BX6    X5 
          SA6    A2 
          AX6    24 
          SX7    B5+B1       SET INDEX
          BX2    -X2*X6      NEW LENGTH 
          MX6    1
          EQ     EBD
  
 EBD4     MX2    -21
          AX5    24 
          SX7    B5+B1       SET INDEX
          BX2    -X2*X5 
          SA5    A3-B1       PREVIOUS DEFINITION
          MX6    0           FLAG REDEFINITION
  
 EBD      PS                 ENTRY/EXIT 
          SA3    TSEG        BEGIN BLOCK TABLE SEARCH 
          SA2    A3+B1
          BX6    X1          STORE NAME AT LWA+1
          SB2    B1+B1       (B2) = 2 
          SB3    X2          (B3) = LENGTH
          SA4    NS 
          SA6    X3+B3
          IX3    X3+X4       FIRST NON-SEGMENT ENTRY
          SA3    X3          FIRST ENTRY
          SB5    X4-2        SKIP SEGMENT ENTRIES IN *TSEG* 
          MX4    42+3 
          LX4    3
 EBD1     BX2    X3-X6       COMPARE NAMES
          SA3    A3+B2       NEXT ENTRY 
          BX2    X4*X2       CURSE - *TPRX* POINTER MUST BE MASKED
          SB5    B5+B2       ADVANCE COUNTER
          NZ     X2,EBD1     LOOP TO HIT
          NE     B5,B3,EBD2  IF NOT LAST ENTRY
          BX2    X5          (X2) = 2ND WORD OF *TSEG* ENTRY
          RJ     AET         ADD ENTRY TO *TSEG*
          SX6    B1          SET NEW DEFINITION 
          BX7    X4          SET INDEX
          IX5    X4+X2
          SA5    X5          (A5) = ADDRESS OF DEFINITION 
          EQ     EBD         RETURN 
 ECD      SPACE  4,10 
**        ECD - ENTER COMMON DEFINITION.
* 
*             THIS ROUTINE ENTERS A COMMON BLOCK NAME INTO *TCOM*.
*         IF THE NAME ALREADY EXISTS IN THE TABLE, THE *G* BIT WILL 
*         BE ORED WITH THE OLD *G* TO EFECTIVELY CAUSE A *GLOBAL* 
*         DECLARATION TO OVERIDE A *COMMON* DECLARATION.  THE SEGMENT 
*         FIELD WILL BE SET TO MINUS ONE  TO INDICATE UNASSIGNED. 
* 
*         ENTRY  (X5) = 42/NAME,1/G,17/0
*         USES   X - 0, 1, 2, 3, 4, 6.
*                B - 2, 3.
*                A - 1, 2, 6. 
*         CALLS  ADW=.
  
  
 ECD      PS     0           ENTRY/EXIT 
          SA1    TCOM 
          MX0    42 
          SA2    A1+B1
          SB3    0
          SB2    X2          (B2) = LENGTH *TCOM* 
          BX6    X0*X5
 ECD1     EQ     B2,B3,ECD2  IF NAME NOT IN TABLE 
          SA2    X1+B3
          BX3    X0*X2
          BX4    X3-X6       COMPARE NAMES
          SB3    B3+B1
          NZ     X4,ECD1     IF NAMES DO NOT MATCH
          BX6    X5+X2       OR *G* BITS
          SA6    A2          SAVE NEW DEFINITION
          EQ     ECD
  
 ECD2     SX0    377776B
          BX1    X0+X5       SET *SEG* FIELD TO -1
          ADDWRD TCOM,X1
          EQ     ECD
 ESD      SPACE  4,8
**        ESD - ENTER SEGMENT DEFINITION INTO *TBLK*. 
* 
*              THE *TBLK* ENTRIES FOR A SEGMENT ARE ADDED IN FOUR PARTS.
*         FIRST THE SEGMENT ENTRY IS ADDED.  THE GLOBAL SAVE BLOCKS ARE 
*         ADDED SECOND.  THE REMAINING BLOCKS ARE ADDED NEXT FOLLOWED 
*         BY THE PROGRAM ENTRIES FOR THE SEGMENT.  THE ENTRIES ARE
*         ADDED TO *TBLK* IN THE ORDER THEY OCCUR IN *TSEG*.  THIS
*         MEANS THAT PROGRAMS AND BLOCKS OCCUR IN THE SAME ORDER AS THEY
*         APPEAR ON *SEGLOAD* DIRECTIVES. 
* 
*              WE MUST BE CAREFUL THAT EACH SEGMENT DEFINES ONLY ONE
*         ONE COPY OF A BLOCK AND THAT COPY HAS THE MAXIMUM LENGTH
*         ASSIGNED TO IT BY PROGRAMS IN THIS SEGMENT. 
* 
*              EACH *TSEG* ENTRY IS MODIFIED AFTER IT HAS BEEN ADDED
*         TO *TBLK*.  WE MUST KNOW THE *TBLK* INDEX OF WHERE IT WAS 
*         DEFINED SO THAT WHEN WE RELOCATE ENTRY POINTS THE ADDRESS 
*         OF THE ENTRY POINT IS CORRECT.  PROGRAM ENTRIES IN *TSEG* HAVE
*         THEIR PROGRAM ADDRESS (*PA*) INSERTED INTO THE *PRU* FIELD
*         BECAUSE THE *PA* ADDRESS FIELD IN *TBLK* CONTAINS THE PRU 
*         ADDRESS OF THE PROGRAM ON DISK AND WE NEED TO THE ADDRESS FOR 
*         RELOCATING ENTRY POINTS.
* 
*         ENTRY  (X1) = SEGMENT INDEX.
*                (X6) = FWA OF SEGMENT. 
*         EXIT   (X1) = FWA OF SEGMENT. 
*                (X2) = LENGTH OF SEGMENT.
*                (X3) = LENGTH OF GLOBAL SAVE BLOCKS. 
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 3, 4, 5, 6, 7.
*                A - 1, 2, 3, 4, 5, 6, 7. 
*         CALLS  ADW=, MBD, CDB.
  
  
 ESD      PS                 ENTRY/EXIT 
          BX2    -X1
          SX7    B0 
          SA6    ESDA 
          SA7    ESDC        SET CURRENT *TSEG* INDEX 
          SB2    X2          (B2) = - SEGMENT INDEX 
          BX7    X0          SAVE (X0)
          SA7    ESDSV
  
*         ADD SEGMENT ENTRY (DELINK TABLE). 
  
          SA2    TSEG 
          IX3    X2+X1
          SA5    X3 
          LX1    3
          MX6    15 
          LX6    18 
          BX6    -X6*X5 
          BX1    X6+X1       ADD SEGMENT INDEX TO DEFINITION
          SA5    A5+B1
          ADDWRD TBLK,X1
          SA3    ESDA        FWA OF SEGMENT 
          BX1    X3+X5       ADD PA FIELD TO DEFINITION 
          AX5    24 
          SX6    X5          LENGTH OF DELINK TABLE 
          IX6    X6+X3
          SA6    A3+B1       SET LWA+1 = FWA + LENGTH 
          SX7    X4 
          SA7    ESDD        INDEX OF SEGMENT ENTRY 
          ADDWRD A2,X1
          SA2    ESDB        LWA+1 OF SEGMENT 
          MX6    -17
          BX6    X6*X2       NZ IF SEGMENT LWA+1 .GE. 400000B 
          ZR     X6,ESD0A    IF SEGMENT STRUCTURE NOT PAST LIMIT
 ESD0     SA1    TSEG        GET SEGMENT NAME 
          SB2    -B2
          SA2    X1+B2
          MX7    42 
          BX7    X7*X2       (X7) = SEGMENT NAME
          ERROR  422,X7      ---- SEGMENT LWA+1 GT 377777B
          EQ     ABEND
  
*         ADD GLOBAL SAVE BLOCKS. 
  
 ESD0A    SA2    TSEG+1 
          SA3    NS 
          SB3    X2 
          SB5    X3+B1       (B5) = CURRENT INDEX OF DEFINITION IN *TSEG
          SB4    B1+B1
 ESD1     GE     B5,B3,ESD2  IF TABLE SCAN COMPLETE 
          SA5    TSEG 
          MX3    1
          SA5    X5+B5       *TSEG* DEFINITION
          LX3    -12
          BX2    X3*X5
          SB5    B5+B4
          SX4    X5 
          ZR     X2,ESD1     IF NOT GLOBAL SAVE 
          NZ     X4,ESD1     IF THIS ENTRY DOES NOT DEFINE BLOCK
          SA1    A5-B1
          MX3    -18
          BX2    -X3*X1 
          AX2    3
          SX3    X2+B2
          NZ     X3,ESD1     IF THIS GLOBAL NOT IN THIS SEGMENT 
          SA2    ESDB 
          SX6    B0          SET *OWN* = 0
          RJ     MBD         MOVE BLOCK DEFINITION
          MI     X4,ESD1     IF GLOBAL BLOCK NOT FOUND
          SA2    TSEG                                                    LDR0235
          SB7    B5-3                                                    LDR0235
          SA2    X2+B7       CURRENT *TSEG* ENTRY                        LDR0235
          SA3    TBLK+1 
          MX7    -18
          SX3    X3-2 
          BX7    -X7*X2 
          LX3    18 
          SA1    ESDC 
          BX7    X7+X3
          IX6    X1+X4
          SA7    A2          SAVE *TBLK* INDEX IN *TSEG* DEFINITION 
          SA6    A1          UPDATE LENGTH OF GLOBAL SAVE BLOCKS
          EQ     ESD1 
  
*         ADD BLOCKS WHICH ARE NOT GLOBAL SAVE. 
  
 ESD2     SA2    TSEG+1 
          SA3    NS 
          SB3    X2 
          SB7    X3          (B7) = CURRENT INDEX IN *TSEG* 
 ESD3     GE     B7,B3,ESD10 IF TABLE SCAN COMPLETE 
          SA5    TSEG 
          SA5    X5+B7       *TSEG* ENTRY 
          LX5    59-0 
          SB7    B7+B4
          PL     X5,ESD3     IF NOT COMMON BLOCK
          LX1    X5,B1       RESTORE BLOCK ENTRY
          SA3    A5+B1
          BX5    X3 
          MX4    3
          MI     X5,ESD3     IF BLOCK NOT REFERENCED
          LX4    -12
          BX4    X4*X5
          ZR     X4,ESD5     IF NOT EQUAL OR GLOBAL BLOCK 
          LX4    13 
          MI     X4,ESD5     IF AN EQUAL BLOCK
          SX6    X5 
          LX4    -1 
          NZ     X6,ESD4     IF NOT DEFINITION OF GLOBAL
          MI     X4,ESD3     IF GLOBAL SAVE BLOCK 
          MX6    -18
          BX2    -X6*X1 
          AX2    3
          SX6    X2+B2
          NZ     X6,ESD3     IF NOT IN THIS SEGMENT 
          SX4    B0 
          EQ     ESD7 
  
 ESD4     MX2    1
          LX2    -11         ADD BIT TO INDICATE BLOCK ALREADY DEFINED
          BX5    X2+X5
          PL     X4,ESD5     IF NOT GLOBAL SAVE 
          MX7    -18
          BX2    -X7*X1 
          SA3    TSEG 
          AX2    3
          IX2    X2+X3
          SA2    X2          PROGRAM ENTRY DEFINING THIS BLOCK
          IX3    X3+X6
          BX2    -X7*X2 
          AX2    3
          SX2    X2+B2
          SA3    X3-1        ENTRY FOR DEFINITION OF GLOBAL SAVE
          NZ     X2,ESD3     IF PROGRAM NOT IN THIS SEGMENT 
          BX2    -X7*X3 
          AX3    18 
          AX2    3
          SB5    X3          *TBLK* INDEX OF ENTRY DEFINING BLOCK 
          SX2    X2+B2
          ZR     X2,ESD9     IF THIS SEGMENT OWNS THIS GLOBAL SAVE
          EQ     ESD6 
  
 ESD5     MX7    -18
          BX2    -X7*X1 
          SA3    TSEG 
          AX2    3
          IX3    X2+X3
          SA3    X3          PROGRAM ENTRY DEFINING THIS BLOCK
          BX2    -X7*X3 
          AX2    3
          SX3    X2+B2
          NZ     X3,ESD3     IF PROGRAM IN ANOTHER SEGMENT
 ESD6     SA2    BC 
          MX6    42 
          BX2    X2-X1       CHECK FOR BLANK COMMON 
          LX1    59-1 
          BX2    X6*X2
          MI     X1,ESD13    IF ECS BLOCK 
          LX1    1-59 
          SB5    B0          *TBLK* INDEX FOR CM // 
          SX6    B0          *OWN* = 0
          ZR     X2,ESD9     IF ENTRY IS CM //
          ZR     X4,ESD7     IF NOT EQUAL OR GLOBAL BLOCK 
          SX6    X5-1 
          SA2    TSEG 
          IX2    X2+X6
          SA2    X2          GLOBAL ENTRY FOR THIS BLOCK
          MX6    -18
          BX2    -X6*X2 
          AX2    3
          SX6    X2+B2
          ZR     X6,ESD7     IF THIS SEGMENT OWNS THIS GLOBAL 
          AX6    X2,B1
          SX6    X6+B1
          LX6    6           POSITION *OWN* 
 ESD7     SB5    B7 
          SB6    B0 
          RJ     CDB         CHECK FOR DUPLICATE BLOCK
          SA2    ESDB 
          ZR     X4,ESD8     IF WE ARE DEFINING THIS BLOCK NOW
          MX2    60          SET *PA* FIELD TO ZERO FOR TIME BEING
 ESD8     RJ     MBD         MOVE BLOCK DEFINITION TO *TBLK*
          SA3    TBLK+1 
          SB5    X3-2 
          MI     X4,ESD3     IF GLOBAL BLOCK NOT FOUND
 ESD9     SA1    TSEG 
          SX3    B5 
          SB5    B7-B4
          SA1    X1+B5
          MX6    -18
          BX2    -X6*X1      SET *TBLK* INDEX INTO *TSEG* ENTRY NAME
          LX3    18 
          BX6    X2+X3
          SA6    A1 
          EQ     ESD3 
  
*         ADD PROGRAM DEFINITIONS.
  
 ESD10    SA2    TSEG+1 
          SA3    NS 
          SB3    X2 
          SB5    X3          (B5) = CURRENT INDEX IN *TSEG* 
 ESD11    GE     B5,B3,ESD12 IF TABLE SCAN COMPLETE 
          SA5    TSEG 
          SA5    X5+B5
          SB5    B5+B4
          LX5    59-0 
          MI     X5,ESD11    IF A BLOCK DEFINTION 
          LX5    0-2
          MI     X5,ESD11    IF A SEGMENT DEFINITION
          MX1    42+3 
          LX5    2-59 
          LX1    3
          MX3    -18
          BX2    -X3*X5 
          BX1    X1*X5
          AX2    3
          SX3    X2+B2
          SA4    A5+B1
          NZ     X3,ESD11    IF PROGRAM NOT IN THIS SEGMENT 
          MI     X4,ESD11    IF PROGRAM NOT REFERENCED
          SA3    ESDB 
          MX6    -18
          BX7    -X6*X5      SAVE SEGMENT INDEX 
          BX5    X4 
          AX4    24 
          SX6    X4          LENGTH OF PROGRAM
          IX6    X6+X3
          SA6    A3          UPDATE LWA+1 OF SEGMENT
          SA4    TBLK+1 
          MX6    -18
          LX4    18 
          BX6    X6*X5
          BX6    X6+X3
          BX7    X7+X4
          SA6    A5+B1       ADD *PA* TO DEFINITION IN *TSEG* 
          SA7    A5          SAVE INDEX OF *TBLK* ENTRY IN *TSEG* NAME
          ADDWRD TBLK,X1
          ADDWRD A2,X5
          SA2    ESDB        LWA+1 OF SEGMENT 
          MX6    -17
          BX6    X6*X2
          ZR     X6,ESD11    IF SEGMENT LWA+1 NOT PAST LIMIT
          EQ     ESD0        SEGMENT LWA+1 GT 377777B 
  
 ESD12    SA1    ESDA        FWA OF SEGMENT 
          SA2    A1+B1
          SA3    A2+B1       LENGTH OF SAVED GLOBAL BLOCKS
          IX2    X2-X1       LENGTH OF SEGMENT
          NZ     B2,ESD12A   IF NOT ROOT SEGMENT
          SX3    B0 
 ESD12A   SA4    ESDSV       RESTORE (X0) 
          BX0    X4 
          EQ     ESD
  
 ECS      IFTEST NE,IP.MECS,0 
 ESD13    SB5    B1+B1
          ZR     X2,ESD9     IF ECS //
          LX1    1-59 
          SA2    TBLK 
          MX7    42+3 
          SA3    A2+B1
          LX7    3
          SB5    B0          (B5) = CURRENT INDEX INTO *TBLK* 
          SX6    B0          *OWN* = 0
          BX1    X7*X1
          SB6    X3          (B6) = LENGTH OF *TBLK*
 ESD14    GE     B5,B6,ESD15 IF END OF TABLE
          SA3    X2+B5
          SB5    B5+B4
          BX3    X3-X1
          BX3    X7*X3
          NZ     X3,ESD14    IF BLOCK NAME AND TYPE BITS DO NOT MATCH 
          SA3    A3+B1
          SB6    B0 
          BX5    X3          USE SAME DEFINITION AS IN EARILER ENTRY
          SB5    B7 
          RJ     CDB         CHECK FOR DUPLICATE BLOCKS IN THIS SEGMENT 
          ADDWRD TBLK,X1
          SB5    X4          INDEX OF ENTRY 
          ADDWRD A2,X5
          EQ     ESD9 
  
 ESD15    SA2    NS 
          SB5    X2 
          SB6    B1          FIND MAX LENGTH OF THIS ECS BLOCK
          RJ     CDB
          SB5    B7 
          SB6    B0 
          RJ     CDB         REMOVE DUP BLOCKS FROM THIS SEGMENT
          SA2    ECSPA
          EQ     ESD8 
 ECS      ELSE
 ESD13    ERROR  104         ---- INSUFFICIENT ECS FL FOR LOAD
          EQ     ABEND
 ECS      ENDIF 
  
 ESDA     CON    0           SEGMENT FWA
 ESDB     CON    0           LWA+1 OF SEGMENT 
 ESDC     CON    0           SAVED GLOBAL LENGTH
 ESDD     CON    0           INDEX OF SEGMENT ENTRY 
 ESDSV    CON    0           REGISTER SAVE AREA 
 FEP      SPACE  4,8
**        FEP - FIND ENTRY POINT. 
* 
*              THIS ROUTINE FINDS THE ENTRY IN *TLNK* FOR THE ENTRY 
*         POINT WHICH IS COMPATIBLE WITH THE SEGMENT MAKING THE 
*         REFERENCE.
* 
*         ENTRY  (X1) = EXTERNAL NAME, LEFT JUST., BITS 0-17 IGNORED. 
*                (B2) = SEGMENT INDEX OF CALLING PROGRAM. 
*         EXIT   (X6) = INDEX OF *TSEG* ENTRY WITH COMPATIBLE ENTRY.
*                     < 0 IF UNSATISFIED OR OMITTED.
*                     = 0 IF NO LOADING WILL OCCUR. 
*         USES   X - 1, 2, 3, 4, 5, 6.
*                B - 3. 
*                A - 1, 2, 3, 4, 5, 6.
*         CALLS  CCP, ELT.
  
  
 FEP      PS                 ENTRY/EXIT 
          SX6    B2 
          MX2    0
          SA6    FEPA        SAVE SEGMENT INDEX 
          RJ     ELT         SEARCH *TLNK* FOR ENTRY POINT
          SA1    FEPA 
          SB2    X1          RESTORE B2 
          ZR     X2,FEP3     IF ENTRY NOT IN TABLE TREAT AS UNSATISFIED 
          SA2    TLNK 
          MX3    2
          IX1    X6+X2
          LX3    -1 
          SA4    X1          GET FIRST ENTRY POINT DEFINITION 
          BX3    X3*X4       CHECK FOR UNSATISFIED OR OMITTED 
          NZ     X3,FEP3     IF WE ARE TO TREAT AS UNSATISFIED
 FEP1     SA5    TSEG 
          LX4    -36
          SX2    X4          *PI* INTO *TSEG* FOR PROGRAM OR BLOCK
          IX2    X2+X5
          SA2    X2          *TSEG* ENTRY FOR DEFINING BLOCK
          BX3    X2 
          LX2    59-0 
          PL     X2,FEP2     IF THIS IS A PROGRAM ENTRY 
          SX2    X3 
          AX2    3
          IX2    X2+X5
          SA3    X2          PROGRAM ENTRY
 FEP2     SX2    X3 
          AX2    3           INDEX INTO *TSEG* FOR SEGMENT ENTRY
          SB3    X2 
          RJ     CCP         CHECK FOR COMPATIBLE PROGRAMS
          PL     X6,FEP      IF WE FOUND COMPATIBLE ENTRY POINT 
          SA2    TLNK 
          SA3    A2+B1
          IX3    X2+X3       LWA+1 OF *TLNK*
          SX1    A4+B1
          IX3    X1-X3
          PL     X3,FEP3     IF WE REACHED END OF *TLNK*
          SA1    A4-B1       ENTRY POINT NAME 
          SA4    A4+B1       NEXT DEFINITION OF SAME ENTRY POINT
          MX3    42 
          IX2    X1-X4
          SA4    A4+B1       (X4) = ENTRY POINT DEFINITION
          BX2    X3*X2
          ZR     X2,FEP1     IF SAME ENTRY POINT
 FEP3     MX6    1
          EQ     FEP
  
 FEPA     CON    0           REGISTER SAVE AREA 
 FER      SPACE  4,8
**        FER - FIND EXTERNAL NAME FOR REFERENCE COUNT. 
* 
*              IF THE NAME IS IN *TEPT1* THEN RETURN THE ADDRESS OF 
*         THE TABLE ENTRY FOR INCREMENTING THE REFERENCE COUNT. 
*         OTHERWISE AN ENTRY IS CREATED.
* 
* -NOTE-       (A0) SHOULD NOT BE USED IF *ATS* IS CALLED.
* 
*         ENTRY  (X1) = EXTERNAL NAME (0L FORMAT).
*                *XI* = INDEX TO START OF EXTERNAL ENTRIES FOR THIS 
*                       PROGRAM.
*                *PI* = PROGRAM INDEX.
*         EXIT   (A0) = ADDRESS OF WORD TO INCREMENT COUNT. 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4. 
*                A - 0, 1, 2, 3.
*         CALLS  ADW=.
  
  
 FER      PS                 ENTRY/EXIT 
          SA2    TEPT1
          SA3    A2+B1
          SB3    X2          (B3) = FWA OF *TEPT1*
          SB4    X3          (B4) = LENGTH OF *TEPT1* 
          SA2    XI 
          MX4    42 
          SB2    X2          (B2) = CURRENT INDEX IN TABLE
 FER1     GE     B2,B4,FER3  IF ENTRY NOT IN TABLE
          SA2    B2+B3
          BX6    X2-X1
          BX6    X4*X6
          ZR     X6,FER2     IF NAMES COMPARE 
          SB2    B2+2 
          EQ     FER1 
  
 FER2     SA0    A2+B1       ADDRESS OF SECOND WORD OF ENTRY
          EQ     FER
  
 FER3     ADDWRD TEPT1,X1 
          SA1    PI 
          LX1    36 
          ADDWRD A2,X1
          IX7    X2+X4
          SA0    X7 
          EQ     FER
 MBD      SPACE  4,8
**        MBD - MOVE BLOCK DEFINITION FROM *TSEG* TO *TBLK*.
* 
*              THIS ROUTINE MOVES A BLOCK ENTRY FROM *TSEG* TO *TBLK*.
*         WE ALSO UPDATE THE LWA+1 OF CM/ECS LOAD.  IF A GLOBAL BLOCK 
*         WAS NEVER REFERENCED (LENGTH IS -0) THEN AN ERROR MESSAGE 
*         IS ISSUED.
* 
*         ENTRY  (X1) = FIRST WORD OF *TSEG* DEFINITION.
*                (X5) = SECOND WORD OF DEFINITION.
*                (X2) = FWA OF BLOCK. 
*                (A2) = ADDRESS OF FWA POINTER TO BE UPDATED UNLESS (X2)
*                       .LT. 0 ON ENTRY.
*                (X6) = *OWN* FIELD POSITIONED TO BITS 6-17.
*         EXIT   (X4) = LENGTH OF BLOCK (NEGATIVE IF GLOBAL BLOCK NOT 
*                       FOUND). 
*         USES   X - ALL. 
*                B - NONE.
*                A - 1, 2, 6, 7.
*         CALLS  ADW=, ERROR. 
  
  
 MBD      PS                 ENTRY/EXIT 
          AX5    24 
          MX0    0           (X0) = 0 FOR BLOCK LWA NOT TOO HIGH
          MX4    -21
          BX4    -X4*X5 
          LX4    -21
          AX4    -21         SIGN EXTEND LENGTH 
          MI     X4,MBD2     IF UNDEFINED GLOBAL
          IX7    X4+X2
          BX3    X1          (X3) = TSEG(0) FOR CM/ECS CHECK
          MI     X2,MBD1     IF WE DO NOT UPDATE CM/ECS PROGRAM ADDRESS 
          SA7    A2          UPDATE LWA+1 OF BLOCK = FWA OF NEXT
          MX0    -17         CHECK SIZE FOR CASE OF CM BLOCK
          BX0    X0*X7       NZ IF THIS BLOCK MAKES SEGMENT TOO BIG 
          LX3    59-1 
          PL     X3,MBD1     IF CM BLOCK
          MX0    -21         CHECK SIZE FOR CASE OF UEM/ECS BLOCK 
          BX0    X0*X7
 MBD1     MX3    3
          LX3    -12-24 
          BX7    X3*X5       *Q*, *V*, *G* BITS 
          LX7    -18
          SX5    B0 
          IX2    X5+X2       CHANGE -0 TO 0 
          LX4    24 
          BX5    X4+X2       ADD PA TO DEFINITION 
          MX3    15 
          LX3    18 
          BX1    -X3*X1 
          BX1    X1+X6
          BX1    X1+X7
          ADDWRD TBLK,X1
          NZ     X0,ESD0     IF SEGMENT LWA+1 .GE. 400000B
          ADDWRD A2,X5
          AX5    24 
          MX4    -21
          BX4    -X4*X5      LENGTH OF BLOCK
          EQ     MBD
  
 MBD2     SX6    B2 
          MX7    42 
          SA6    MBDA        SAVE B2, B3
          BX7    X7*X1
          SX6    B3 
          SA6    A6+B1
          SA4    LSBN        DO NOT ISSUE THIS ERROR FOR THE LOCAL SAVE 
          IX4    X7-X4        BLOCK 
          ZR     X4,MBD3     IF *S$A$V$E$ 
          ERROR  4420,X7     ---- CANNOT FIND GLOBAL BLOCK
 MBD3     SA1    MBDA        RESTORE B2, B3 
          MX4    60 
          SA2    A1+B1
          SB2    X1 
          SB3    X2 
          EQ     MBD
  
 MBDA     BSS    2           REGISTER SAVE AREA 
 MCB      SPACE  4,10 
**        MCB - MOVE COMMON BLOCKS. 
* 
*             THIS ROUTINE WILL ASSIGN THE COMMON BLOCKS IN *TCOM* TO 
*         THE NEAREST COMMON ANCESTOR OF ALL SEGMENTS WHICH USE IT. 
*         IF A MOVEABLE PROGRAM PRESETS THE COMMON BLOCK, IT IS ALSO
*         MOVED TO THE NEAREST COMMON ANCESTOR. 
* 
*         USES   X - 0, 1, 2, 3, 5, 6, 7. 
*                B - 2, 3, 4, 5, 6, 7.
*                A - 0, 1, 2, 3, 6, 7.
*         CALLS  NCA. 
  
  
 MCB      PS     0           ENTRY/EXIT 
          SA1    TCOM 
          SA2    A1+B1
          SB4    X1          (B4) = FWA *TCOM*
          SA0    B0 
          SB5    B4+X2       (B5) = LWA+1 *TCOM*
          SA1    TSEG 
          SA3    NS 
          SA2    A1+B1
          SB6    X1          (B6) = FWA OF *TSEG* 
          SB2    X3          (B2) = *TSEG* INDEX OF NONSEGMENT ENTRIES
          MX0    42 
          SB7    X2+         (B7) = LENGTH OF *TSEG*
 MCB1     GE     B4,B5,MCB   IF END OF *TCOM* REACHED 
          SA1    B4          GET ENTRY FROM *TCOM*
          SB4    B4+B1       ADJUST *TCOM* POINTER
          SX2    X1 
          MI     X2,MCB1     IF GLOBAL BLOCK
          SX7    B0          INITIALIZE MATCH FOUND FLAG
          SX6    37777B 
          BX5    X0*X1       EXTRACT NAME 
          SB3    B2          (B3) = *TSEG* INDEX OF NONSEGMENT ENTRIES
 MCB2     GE     B3,B7,MCB3  IF END OF *TSEG* REACHED 
          SA1    B3+B6       GET ENTRY FROM *TSEG*
          LX1    59-0 
          SB3    B3+2        INCREMENT *TSEG* INDEX 
          PL     X1,MCB2     IF NOT COMMON BLOCK
          LX1    0-59        RESTORE X1 
          BX2    X0*X1       EXTRACT NAME 
          BX3    X2-X5       COMPARE NAMES
          AX1    3
          NZ     X3,MCB2     IF MISMATCH
          MX2    -15
          SX7    X7+B1       INCREMENT MATCH FOUND FLAG 
          BX2    -X2*X1      EXTRACT SEGMENT INDEX
          SX1    X6          CURRENT NCA
          RJ     NCA         DETERMINE NEAREST COMMON ANCESTOR
          EQ     MCB2        LOOP FOR ALL OF *TSEG* 
  
 MCB3     ZR     X7,MCB1     IF NO MATCHES FOUND
          SX1    B1 
          IX7    X7-X1
          NZ     X7,MCB3A    IF MORE THAN 1 PROGRAM REFERENCED BLOCK
          SA1    B6+X6
          MX2    -17
          BX2    -X2*X1 
          AX2    3
          SX1    X6 
          SX3    X2-37777B
          ZR     X3,MCB1     IF THE ONLY REF. PROGRAM IS UNASSIGNED 
          RJ     NCA         DETERMINE NCA OF OWNING PROGRAM
 MCB3A    BX7    X6+X5       MERGE NAME AND INDEX OF NCA
          SB3    B2          (B3) = *TSEG* INDEX OF NONSEGMENT ENTRIES
          SA7    B4-1 
 MCB4     GE     B3,B7,MCB1  IF END OF *TSEG* 
          SA1    B3+B6       GET WORD FROM *TSEG* 
          LX1    59-0 
          SB3    B3+2        INCREMENT *TSEG* INDEX 
          PL     X1,MCB4     IF NOT COMMON BLOCK
          LX1    0-59 
          BX2    X0*X1       EXTRACT NAME 
          BX3    X5-X2       COMPARE NAMES
          NZ     X3,MCB4     IF NAMES ARE DIFFERENT 
          SA2    A1+B1
          LX2    59-23
          PL     X2,MCB4     IF NOT PRESET BY OWNING PROGRAM
          BX2    -X0*X1      EXTRACT SEGMENT INDEX
          AX2    3
          SA2    B6+X2
          SX3    X2 
          PL     X3,MCB4     IF FIXED MODULE
          AX3    3
          MX1    -14
          BX3    -X1*X3      EXTRACT SEGMENT INDEX
          IX3    X6-X3
          ZR     X3,MCB4     IF ALREADY PROVISIONALY ASSIGNED TO NCA
          BX3    X6          SAVE X6
          LX1    3
          SA0    B1          FLAG PROGRAM MOVED 
          LX6    3
          BX1    X1*X2       MASK OUT OLD SEGMENT INDEX 
          BX6    X6+X1       MERGE IN NEW SEGMENT INDEX 
          SA6    A2 
          BX6    X3          RESTORE X6 
          EQ     MCB4        LOOP FOR REST OF *TCOM*
 NCA      SPACE  4,8
**        NCA - NEAREST COMMON ANCESTOR.
* 
*         ENTRY  (X1) = SEGMENT INDEX OF PROGRAM 1. 
*                (X2) = SEGMENT INDEX OF PROGRAM 2. 
*         EXIT   (X6) = SEGMENT INDEX OF NEAREST COMMON ANCESTOR. 
*         USES   X - 1, 2, 3, 4, 6. 
*                B - NONE.
*                A - 3, 4.
  
  
 NCA      PS                 ENTRY/EXIT 
          SA3    TSEG 
          SX4    X1-37777B
          SX6    X2 
          ZR     X4,NCA      IF ONE IS A FLOATER
          SX6    X1 
          SX4    X2-37777B
          ZR     X4,NCA      IF ONE IS A FLOATER
 NCA1     IX4    X1-X2
          SX6    X1 
          ZR     X4,NCA      IF WE FOUND N. C. A. 
          PL     X4,NCA2     IF (X1) .GT. (X2)
          LX1    X2 
          BX2    X6 
 NCA2     IX4    X3+X1       GET ANCESTOR OF (X1) 
          SA4    X4 
          MX6    -17
          BX6    -X6*X4 
          AX6    3
          ZR     X6,NCA      IF THIS IS PATRIARCH OR SON OF ROOT
          SX1    X6 
          SX6    X6-37777B
          ZR     X6,NCA      IF THIS IS PATRIARCH 
          EQ     NCA1        TRY NEXT ANCESTOR
 PDP      SPACE  4,8
**        PDP - PROCESS DUPLICATE PROGRAM NAME. 
* 
*              IF THE DUPLICATE PROGRAM IS FROM A FILE, A NON-FATAL 
*         ERROR IS GIVEN AND THE PROGRAM IS SKIPPED.
* 
*              UNDER NOS, A DUPLICATE FROM A LIBRARY IS SKIPPED 
*         WITHOUT COMMENT.
* 
*              UNDER SCOPE, A DUPLICATE FROM A LIBRARY RESULTS IN A 
*         NON-FATAL ERROR AND THE PROGRAM IS LOADED.
* 
*         ENTRY  (A5) = ADDRESS OF *TSEG* DEFINITION. 
*                *WC* = NO. OF WORDS REMAINING IN TABLE.
*         EXIT   RETURN TO *RDR* IF PROGRAM SKIPPED AND EOR OR EOF. 
*                          *FPP* IF PROGRAM SKIPPED AND NOT EOR OR EOF. 
*         USES   X - ALL. 
*                B - 2. 
*                A - ALL. 
*         CALLS  ADW=, ERROR, SKP.
  
  
 PDP      PS                 ENTRY/EXIT 
          SA2    FI 
          SA1    TLFN 
          SB2    X2 
          SA3    X1+B2
          SX3    X3          (X3) = FILE TYPE 
          MX1    42 
          SA5    A5-B1
          BX7    X1*X5       (X7) = PROGRAM NAME
          IFNOS  1
          NZ     X3,PDP1     IF FROM LIBRARY SKIP WITHOUT COMMENT 
          IFSCOPE 1 
          NZ     X3,PDP2     IF FROM LIBRARY ISSUE ERROR AND LOAD 
          ERROR  4103,X7     ---- DUPLICATE PROGRAM FROM FILE 
 PDP1     SA1    WC 
          SX5    X1+B1
          WRITER O,RCL       COMPLETE RECORD
          RJ     /READ/SKP   SKIP THIS PROGRAM
          SA2    IL 
          SX6    X2 
          SA6    TREQ2+1     RESET LENGTH OF *LDSET* TABLE
          ZR     X1,FPP      IF NO EOR OR EOF,READ NEXT PROGRAM 
          EQ     /READ/RDR
  
 S        IFSCOPE 
 PDP2     ERROR  4104,X7     ---- DUPLICATE PROGRAM FROM LIBRARY
          SA1    ERRORSV     (X1) = PROGRAM NAME
          SA4    PL 
          SA3    FI 
          LX3    24 
          BX5    X3+X4
          LX5    24          (X5) = 12/FI,24/L,24/0 
          ADDWRD TSEG,X1     ADD PROGRAM NAME 
          SX7    X4 
          SA7    PI          SAVE PROGRAM INDEX 
          ADDWRD A2,X5       ADD DEFINITION 
          EQ     PDP
 S        ENDIF 
 RPN      SPACE  4,8
**        RPN - REMOVE PROGRAM NAME FROM *TUSEP*. 
* 
*              PROGRAM NAMES FROM *SEGLOAD* DIRECTIVES ARE ADDED TO 
*         *TUSEP* AND WHEN THEY ARE ENCOUNTERED THE NAMES MUST BE 
*         REMOVED FROM *TUSEP* SO THAT *SAT* WILL NOT SEARCH FOR THEM.
* 
*         ENTRY  (X1) = PROGRAM NAME. 
*         USES   X - 1, 2, 3, 6.
*                B - 2, 3.
*                A - 2, 3, 6. 
  
  
 RPN      PS                 ENTRY/EXIT 
          SA2    TUSEP
          SA3    A2+B1
          MX6    42 
          BX1    X6*X1
          SB2    X3          (B2) = LENGTH OF *TUSEP* 
          SB3    B0          (B3) = CURRENT ENTRY IN *TUSEP*
 RPN1     EQ     B2,B3,RPN2  IF NAME NOT IN *TUSEP* 
          SA3    X2+B3
          SB3    B3+B1
          BX6    X1-X3
          NZ     X6,RPN1     IF ENTRY DOES NOT MATCH
          SA6    A3          ZERO THIS ENTRY
 RPN2     ZR     B2,RPN      IF LENGTH OF *TUSEP* IS ZERO 
          SA1    X2 
          SX6    X2+B1
          NZ     X1,RPN      IF FIRST ENTRY IS NON-ZERO 
          SA6    A2          RESET FWA OF *TUSEP* 
          SB2    B2-B1
          BX2    X6 
          SX6    B2 
          SA6    A2+B1       RESET LENGTH OF *TUSEP*
          EQ     RPN2 
 RRP      SPACE  4,8
**        RRP - READ REPLICATION PAIRS. 
* 
*              A PAIR OF WORDS FROM *REPL* OR *XREPL* TABLES DESCRIBING 
*         A REPLICATION ARE CRACKED AND THE APPROPRIATE DEFAULT VALUES
*         ENTERED IF NEEDED.
* 
*         ENTRY  (X0) " 0 FOR *REPL* TABLE. 
*         EXIT   (X1) = DR. 
*                (X2) = SR. 
*                (X3) = B.
*                (X4) = K.
*                (X5) = C.
*                (X6) = D.
*                (X7) = S.
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                B - NONE.
*                A - 1, 6.
*         CALLS  RDO=, WTO=.
  
  
 RRP      PS                 ENTRY/EXIT 
          BX6    X0 
          SA6    RRPA        SAVE REPL FLAG 
          READO  L
          BX0    X6 
          WRITEO O
          READO  L
          WRITEO O
          BX5    X6 
          SA1    RRPA 
          BX4    X0 
          BX0    X1          RESTORE X0 
          MX1    -9 
          MX2    -18
          MX3    -15
          ZR     X0,RRP1     IF *XREPL* TABLE 
          BX7    -X2*X4      S
          BX6    -X2*X5      D
          AX5    18 
          AX4    18 
          BX2    -X1*X4      SR 
          BX1    -X1*X5      SD 
          AX5    9
          AX4    9
          BX3    -X3*X5      B
          AX5    15 
          SX4    X4          K
          EQ     RRP2 
  
 RRP1     MX6    -24
          BX7    -X6*X4      S
          BX6    -X6*X5      D
          AX4    24 
          AX5    24 
          BX2    -X1*X4      SR 
          BX1    -X1*X5      SD 
          AX4    9
          AX5    9
          SX4    X4          K
          MX3    -12
          BX3    -X3*X5      B
          AX5    12          C
 RRP2     NZ     X3,RRP3     IF B " 0 
          SX3    B1          B = 1
 RRP3     NZ     X5,RRP4     IF C " 0 
          SX5    B1          C = 1
 RRP4     NZ     X4,RRP5     IF K " 0 
          SX4    X3          K = B
 RRP5     NZ     X6,RRP      IF D " 0 
          IX6    X7+X3       D = S+B
          SX1    X2          SD = SR
          EQ     RRP
  
 RRPA     CON    0           REGISTER SAVE AREA 
 SLG      SPACE  4,8
**        SLG - SET LENGTH OF GLOBAL TO MAXIMUM SPECIFIED.
* 
*              THE LENGTH OF A GLOBAL BLOCK IS THE MAXIMUM OF ALL 
*         DECLARED LENGTHS FOR THAT BLOCK AND ANY EQUATED BLOCKS. 
* 
*         ENTRY  (X2) = LENGTH OF NEW ENTRY.
*                (X7) = DEFINITION OF GLOBAL BLOCK OR ZERO IF NONE. 
*         USES   X - 1, 2, 3, 7.
*                B - NONE.
*                A - 3, 7.
  
  
 SLG      PS                 ENTRY/EXIT 
          ZR     X7,SLG      IF NOT GLOBAL OR EQUAL BLOCK 
          SA3    TSEG 
          IX3    X3+X7
          SA3    X3          DEFINITION OF GLOBAL BLOCK 
          MX7    21 
          LX3    59-44
          BX1    X7*X3       OLD LENGTH 
          AX1    -21         SIGN EXTENDED
          BX3    -X7*X3 
          IX7    X2-X1
          LX3    21 
          AX7    60 
          BX1    X7*X1
          BX2    -X7*X2 
          BX7    X2+X1       MAX(OLD LENGTH,NEW LENGTH) 
          BX7    X7+X3
          LX7    24 
          SA7    A3          UPDATE DEFINITION OF GLOBAL
          EQ     SLG
  
  
          IDENT              SEGMENT GENERATION - INITIALIZATION. 
          TITLE  SEGMENT GENERATION - INITIALIZATION. 
          SPACE  4,8
**        SYMBOL DEFINITIONS FOR INITIALIZATION.
  
  
 P0       BSS    0           FWA OF INITIALIZATION CODE 
 BL       CON    0           PL IF LEADING BLANKS ARE NOT SKIPPED 
 EF       CON    0           NZ IF END HAS BEEN ENCOUNTERED 
 IN       CON    0           NZ IF INPUT FILE WAS NOT EMPTY 
 LB       CON    0           LABEL FOR CURRENT DIRECTIVE
 NP       CON    0           CURRENT LEVEL IN PARENTHESIS 
 RI       CON    -1          ROOT SEGMENT INDEX IN *TSCR1*
          SPACE  4,8
**        SEGMENT LOADER ERROR MESSAGES FOR INITIALIZATION. 
* 
*              THE *SEGLOAD* DIRECTIVE ERRORS ARE GENERATED HE
*         THAN IN *LOADM* BECAUSE THE ERRORS SHOULD APPEAR IMMEDIATELY
*         AFTER THE DIRECTIVE.  IF THIS WERE NOT THE CASE WE WOULD
*         BE FORCED TO NUMBER THE DIRECTIVES AND REFERENCE THEM BY
*         THE DIRECTIVE NUMBER.  THE ERROR PROCESSOR *ERR* IS CALLED
*         WHENEVER A DIRECTIVE ERROR OCCURS.
  
  
 SEGERR0  DATA   C* SEGLOAD INPUT FILE EMPTY OR MISPOSITIONED.* 
 SEGERR1  DATA   C* SEGLOAD DIRECTIVE ERRORS - SEE MAP.*
 ERR400   DATA   C+0         FE400 *** UNBALANCED PARENTHESIS.+ 
 ERR401   DATA   C+0         FE401 *** MISSING PARAMETER.+
 ERR402   DATA   C+0         FE402 *** ILLEGAL SEPARATOR.+
 ERR403   DATA   C+0         FE403 *** ....... - UNRECOGNIZABLE DIRECTIV
,E.+
 ERR404   DATA   C+0         FE404 *** INCOMPLETE PARAMETER.+ 
 ERR405   DATA   C+0         FE405 *** ....... - USED ON LOWER LEVEL.+
 ERR406   DATA   C+0         FE406 *** ....... - CONFLICTS WITH EARLIER 
,USAGE.+
 ERR407   DATA   C+0         FE407 *** MORE THAN ONE ROOT SEGMENT.+ 
 ERR410   DATA   C+0         FE410 *** NO ROOT SEGMENT.+
 ERR411   DATA   C+0         FE411 *** MORE THAN 4095 SEGMENTS.+
 ERR412   DATA   C+0         FE412 *** ....... - UNDEFINED SEGMENT.+
 ERR4400  DATA   C*0         NE4400/// PARAMETER NAME TRUNCATED TO 7 CHA
,RACTERS.*
 ERR4401  DATA   C*0         NE4401/// END CARD MISSING.* 
 ERR4402  DATA   C+0         NE4402/// ....... - NOT DECLARED GLOBAL.+
 VERBS    SPACE  4,8
**        SEGLOAD DIRECTIVE PROCESSOR TABLE.
* 
*              BELOW ARE ALL THE LEGAL DIRECTIVE VERBS ALLOWED AS INPUT 
*         TO THE SEGMENT LOADER.  IF A NEW DIRECTIVE IS TO BE ADDED,
*         ADD THE ENTRY TO THIS TABLE IN THE FORMAT.
* 
*         VFD    42/NAME,18/ADDRESS OF PROCESSOR
  
  
 VERBS    VFD    42/0LTREE,18/TREE
          VFD    42/0LGLOBAL,18/GLOBAL
          VFD    42/0LINCLUDE,18/INCLUDE
          VFD    42/0LLEVEL,18/LEVEL
          VFD    42/0LEQUAL,18/EQUAL
          VFD    42/0LCOMMON,18/COMMON
          VFD    42/0LEND,18/END
 LVERBS   =      *-VERBS     LENGTH OF VERB TABLE 
 SEGBILD  SPACE  4,8
**        INITIALIZATION MAIN LOOP. 
* 
*              SEGMENT LOADS ARE INITIATED HERE BY *LOADC* WHEN A 
*         *SEGLOAD* CONTROL CARD WAS ENCOUNTERED.  THE PURPOSE OF 
*         INITIALIZATION IS TO READ THE INPUT DIRECTIVES AND GENERATE A 
*         TREE DIAGRAM.  IN THE PROCESS THE TABLE *TSEG* IS BUILD TO
*         REFLECT THE INPUT DIRECTIVES.  ANY ERRORS OCCURRING IN THE
*         DIRECTIVES ARE ISSUED BY THE ERROR ROUTINE IN THIS PART OF
*         *LOADS*.  IF ANY FATAL ERRORS HAVE OCCURED OR IF *LDSET(ERR)* 
*         SPECIFIES TO ABORT ON NON-FATAL ERRORS, AN ABORT IS MADE
*         BEFORE THE TREE DIAGRAM IS GENERATED.  THROUGHOUT THE 
*         INITIALIZATION THE CIO BUFFER IS DIVIDED INTO TWO BUFFERS.
*         ONE FOR FET *O* AND ONE FOR FET *L*.
  
  
 SEGBILD  BSS    0
          SA2    GLOBMAP
          SA1    MAPTYPE
          LX2    59-0 
          PL     X2,INIT0    IF *LDSET* MAP NOT USED
          SX6    X2 
          SX1    X2 
          SA6    A1 
 INIT0    NZ     X1,INIT1    IF MAP NOT SELECTED
          SA1    SEGMAP 
          PL     X1,INIT1    IF *LO* OPTION ON *SEGLOAD* GIVEN
          SX6    B0 
          SA6    A1          SUPPRESS MAP 
 INIT1    RJ     RDI         READ DIRECTIVE INPUT 
          RJ     CFE         CHECK FOR MORE INPUT ERRORS
          SA1    FE 
          NZ     X1,INIT2    IF JOB SHOULD BE ABORTED 
          RJ     MST         MOVE SEGMENTS FROM TABLE *TSCR1* TO *TSEG* 
          RJ     ASN         ASSIGN A PROGRAM ENTRY FOR EACH SEGMENT
          RJ     GTD         GENERATE TREE DIAGRAM
          SA1    SEGMAP 
          ZR     X1,PASS1    IF NO MAP WRITTEN
          WRITER O,RCL
          EQ     PASS1       START PASS 1 OF SEGMENT LOAD 
  
 INIT2    SA1    SEGMAP 
          ZR     X1,INIT3    IF NO MAP WRITTEN
          WRITER O,RCL
 INIT3    SA1    SEGMAP 
          LX1    59-0 
          PL     X1,ABORT    IF DAYFILE MESSAGE ALREADY APPEARS 
          ERROR  CAT,SEGERR1 ---- SEGLOAD DIRECTIVE ERRORS - SEE MAP
          TITLE  SEGMENT GENERATION - INITIALIZATION MAIN ROUTINES. 
 ASN      SPACE  4,8
**        ASN - ASSIGN A SEGMENT NAME.
* 
*              FOR EACH SEGMENT ENTRY IN *TSEG* A PROGRAM ENTRY IS
*         ADDED TO *TSEG* WITH THE SAME NAME.  UNLESS A PROGRAM BY
*         THAT NAME HAS ALREADY BEEN ASSIGNED TO A SEGMENT, THIS
*         ROUTINE WILL DEFINE ONE AND ASSIGN IT TO THE SEGMENT OF THE 
*         SAME NAME.  PROGRAM NAMES ARE ADDED TO *TUSEP* FOR EACH 
*         SEGMENT NAME TO INSURE THAT A PROGRAM OF THAT NAME IS LOADED. 
* 
*         USES   X - 0, 1, 2, 6.
*                B - 3, 4, 5, 6, 7. 
*                A - 1, 2.
*         CALLS  ADW=.
  
  
 ASN      PS                 ENTRY/EXIT 
          SA2    NS 
          MX0    42+3 
          SB5    B1+B1
          SB7    X2 
          SA2    TSEG+1 
          LX0    3
          SB6    -B5
          SB4    X2          (B4) = CURRENT LENGTH OF *TSEG*
 ASN1     SB6    B6+B5
          GE     B6,B7,ASN4  IF *TSEG* SCAN COMPLETE
          MX6    42 
          SA1    TSEG 
          SA2    X1+B6       SEGMENT ENTRY
          BX6    X6*X2
          SB3    B7 
 ASN2     GE     B3,B4,ASN3  IF PROGRAM ENTRY NOT IN TABLE
          SA2    X1+B3
          SB3    B3+B5
          BX2    X2-X6
          BX2    X0*X2
          NZ     X2,ASN2     IF THIS IS NOT THE ENTRY WE WANT 
          EQ     ASN1 
  
 ASN3     SX1    B6 
          LX1    3
          BX1    X1+X6
          MX2    1
          RJ     AET         ADD ENTRY TO *TSEG*
          EQ     ASN1 
  
 ASN4     SA2    TUSEP+1
          SB6    B0 
          SB4    X2          (B4) = CURRENT LENGTH OF *TUSEP* 
 ASN5     GE     B6,B7,ASN   IF ADDITIONS TO *TUSEP* COMPLETE 
          SA1    TSEG 
          SB3    B0 
          SA1    X1+B6
          MX0    42 
          SB6    B6+B5
          SA2    TUSEP
          BX6    X0*X1
 ASN6     GE     B3,B4,ASN7  IF PROGRAM NAME NOT IN *TUSEP* 
          SA1    X2+B3
          SB3    B3+B1
          BX1    X1-X6
          BX1    X0*X1
          NZ     X1,ASN6     IF NOT THE PROGRAM WE WANT 
          EQ     ASN5        NAME ALREADY IN TABLE
  
 ASN7     ADDWRD A2,X6       ADD PROGRAM NAME TO TABLE
          EQ     ASN5 
 CFE      SPACE  4,8
**        CFE - CHECK FOR ERRORS. 
* 
*              BEFORE THE SEGMENT ENTRIES IN *TSCR1* ARE ADDED TO 
*         *TSEG* WE MUST BE SURE THAT CERTAIN ERRORS DO NOT CAUSE 
*         THE ALGORITHM USED IN *MST* TO BE CONFUSED.  WE ALSO DETERMINE
*         THE ONE AND ONLY ROOT SEGMENT AND THE NUMBER OF SEGMENTS
*         IN *TSCR1* (DISCARDING TREE NAME ENTRIES).  OTHER ERRORS, 
*         SUCH AS BLOCK NAMES EXPECTED TO BE MADE GLOBAL BUT WERE NOT 
*         ENCOUNTERED ON A *GLOBAL* DIRECTIVE, ARE DETECTED NOW.
* 
*         EXIT   *NS* = NUMBER OF SEGMENTS * 2 IN *TSCR1*.
*                *RI* = INDEX OF ROOT SEGMENT IN *TSCR1*. 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 3, 5, 6, 7.
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  ERR, SFN=. 
  
  
 CFE      PS                 ENTRY/EXIT 
          SA1    TSCR1
          SA2    A1+B1
          SB5    X1          (B5) = FWA OF *TSCR1*
          SB6    X2          (B6) = LENGTH OF *TSCR1* 
          SB7    B0          (B7) = CURRENT INDEX INTO *TSCR1*
 CFE1     GE     B7,B6,CFE6  IF END OF TABLE
          SA1    B5+B7
          SA2    A1+B1
          SB7    B7+2 
          MI     X2,CFE1     IF A TREE ENTRY - IGNORE 
          SX7    X2          LEVEL
          LX2    59-58
          MI     X2,CFE2     IF SEGMENT UNDEFINED 
          SA3    NS 
          SX6    X3+2        INCREMENT NUMBER OF SEGMENTS * 2 
          SA6    A3 
          SX4    X1-77777B
          NZ     X7,CFE1     IF NOT LEVEL 0 
          NZ     X4,CFE1     IF NOT A ROOT SEGMENT
          SA4    RI 
          PL     X4,CFE5     IF ROOT ALREADY EXISTS 
          SX6    A1-B5
          SA6    A4          SAVE INDEX TO ROOT SEGMENT 
          EQ     CFE1 
  
 CFE2     SB3    ERR412      SEGMENT NOT DEFINED
          MX6    42 
          BX1    X6*X1
          RJ     SFN=        SPACE FILL NAME
          SA1    B3+2 
          MX2    42 
          BX6    X2*X6
          BX1    -X2*X1 
          BX6    X6+X1
          SA6    A1          ADD NAME TO ERROR MESSAGE
 CFE4     SA1    FE 
          SX7    B7 
          SA7    CFEA        SAVE B7
          RJ     ERR         ISSUE ERROR MESSAGE
          SA1    TSCR1
          SA2    CFEA 
          SA3    A1+B1
          SB5    X1 
          SB6    X3 
          SB7    X2          RESTORE REGISTERS
          EQ     CFE1 
  
 CFE5     SA1    CFEB 
          SX6    X1+B1
          SA6    A1          FLAG FOR ERROR ALREADY ISSUED
          NZ     X1,CFE1     IF ERROR ALREADY ISSUED
          SB3    ERR407      MORE THAN ONE ROOT SEGMENT 
          EQ     CFE4        ISSUE ERROR AND CONTINUE 
  
 CFE6     SA1    RI 
          PL     X1,CFE7     IF ROOT SEGMENT DEFINED
          SB3    ERR410      NO ROOT SEGMENT
          SA1    FE 
          RJ     ERR         ISSUE ERROR
 CFE7     SA1    NS 
          SX2    X1-4096*2
          MI     X2,CFE8     IF LESS THAN 4096 SEGMENTS DEFINED 
          SB3    ERR411 
          SA1    FE 
          RJ     ERR         ISSUE ERROR
 CFE8     SA1    TSEG 
          SA2    A1+B1
          SB7    B0          (B7) = CURRENT INDEX INTO *TSEG* 
          SB5    X1          (B5) = FWA OF *TSEG* 
          SB6    X2          (B6) = LENGTH OF *TSEG*
 CFE9     GE     B7,B6,CFE   IF END OF TABLE SEARCH 
          SA1    B5+B7
          SA2    A1+B1
          LX1    59-0 
          SB7    B7+2 
          PL     X1,CFE9     IF A PROGRAM ENTRY 
          LX1    0-59 
          LX2    59-46
          MI     X2,CFE9     IF *EQUAL* BIT SET 
          LX2    46-45
          MI     X2,CFE9     IF *GLOBAL* BIT SET
          MX6    1
          BX6    X6+X2
          MX2    1
          LX6    45-59       SET GLOBAL BIT 
          BX6    -X2*X6      CLEAR R=1
          SA6    A2          RESTORE ENTRY IN TABLE 
          MX3    42 
          BX1    X3*X1
          RJ     SFN=        SPACE FILL NAME
          SB3    ERR4402     BLOCK NOT DEFINED AS GLOBAL
          SA1    B3+2 
          MX3    42 
          BX6    X3*X6
          BX1    -X3*X1 
          BX6    X6+X1
          SA6    A1          ADD NAME TO ERROR MESSAGE
          SX7    B7 
          SA1    NE 
          SA7    CFEA        SAVE B7
          RJ     ERR         ISSUE ERROR
          SA1    CFEA        RESTORE REGISTERS
          SA2    TSEG 
          SA3    A2+B1
          SB7    X1 
          SB5    X2 
          SB6    X3 
          EQ     CFE9 
  
 CFEA     BSS    1           REGISTER SAVE AREA 
 CFEB     CON    0           FLAG FOR ERROR ALREADY ISSUED
 GTD      SPACE  4,8
**        GTD - GENERATE TREE DIAGRAM.
* 
*              THE SEGMENTS GIVEN AT THE FRONT OF *TSEG* ARE SCANED AND 
*         A TREE DIAGRAM GENERATED FROM THE INDICATED TREE STRUCTURE. 
*         A LINE OF *=* DENOTES THE SEPARATION OF LEVELS.  ALL
*         PATRIARCHS ARE PRECEDED BY A -*- BEFORE THE NAME.  THOSE
*         SEGMENTS FORTUNATE ENOUGH TO HAVE DAUGHTERS (SONS) HAVE A 
*         LINE OF *?* LEADING FROM THE SEGMENT NAME TO ITS ANCESTORS. 
* 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  AMU=, ATS=, FNP, SFN=, RPC, GNA, WOF, WTL. 
  
  
 GTD      PS                 ENTRY/EXIT 
          PRINT  (=2L  )     PRINT 2 BLANK LINES IF DIRECTIVES LISTED 
          PRINT  (=2L  )
          SA1    SEGMAP 
          LX1    59-1 
          MX0    42 
          PL     X1,GTD      TREE DIAGRAM NOT REQUESTED 
          SX6    B1 
          SA6    A1          SET BIT 0 TO FOOL *WOF*
          SMSG   DBG3 
          SX1    GTDE 
          RJ     WTL         PRINT HEADER LINE
          ALLOC  TSCR,60     ALLOCATE SCRATCH TABLE 
          SB4    X2          (B4) = FWA OF *TSCR* 
          SX7    B0 
 GTD1     SA7    X2 
          SX2    X2+B1
          SX1    X1-1        ZERO ALLOCATED SPACE 
          NZ     X1,GTD1     IF NOT COMPLETE ZEROING
 GTD2     SA1    GTDC 
          BX6    X1 
          SA6    B4          TSCR(0)
          SA6    GTDA 
          NG     X1,GTD12    IF TREE DIAGRAM COMPLETE 
          RJ     FNP         FIND NEXT PATRIARCH
          SA6    GTDC        NEXT PATRIARCH 
          SA1    B4          TSCR(0)
          SA3    PGSIZ
          R=     X6,2 
          IX6    X3-X6
          SA3    /LOADM/LC
          IX4    X6-X3       LINES REMAINING
          IX3    X4-X7
          PL     X3,GTD3     IF TREE WILL FIT ON PAGE 
          R=     X2,16
          IX4    X4-X2
          PL     X4,GTD3     IF ENOUGH OF PAGE LEFT - PRINT ANYWAY
          SA6    A3 
 GTD3     SX2    X1+B5
          SA2    X2+B1
          AX2    -12
          SX6    X2          LEVEL
          SA3    GTDB        OLD LEVEL
          IX4    X6-X3
          SB7    B0          (B7) = DEPTH IN TABLE *TSCR* 
          SA6    A3 
          ZR     X4,GTD4     IF ON SAME LEVEL 
          SX1    =2L
          RJ     WTL         PRINT BLANK LINE 
          SX1    GTDD 
          RJ     WTL         WRITE LINE WITH *=====*
 GTD4     SX1    =2L
          RJ     WTL         WRITE BLANK LINE 
 GTD5     SB6    57          MAX. GENERATIONS PER LINE
          SX4    30B         WILL BECOME (_)
          NZ     B7,GTD6     IF NOT A PATRIARCH 
          SX4    12B         WILL BECOME (*)
 GTD6     SA3    B7+B4
          SA2    X3+B5       TSEG ENTRY 
          SA1    LINE 
          BX6    X1 
          GT     B7,B6,GTD7  IF TOO MANY GENERATIONS - IGNORE NAME
          BX1    X0*X2       NAME 
          RJ     SFN=        SPACE FILL  NAME 
 GTD7     BX1    X6-X4       ADD (*) OR (_) 
          LX1    -6 
          SB2    B7+B7
          SB3    B2+7 
          RJ     RPC         ADD NAME TO LINE 
          SB6    57 
          GT     B7,B6,GTD9  IF TOO MANY GENERATIONS IGNORE ANCESTORS 
          SX1    LINE 
          RJ     WTL         WRITE LINE WITH SEGMENT NAMES
          SA1    B4+B7       TSCR(B7) 
          SB2    X1+2        START LOOKING HERE 
          RJ     GNA         GET NEXT ANCESTOR
          ZR     X6,GTD9     IF NO ANCESTORS FOR THIS SEGMENT 
          SB2    X6+2 
          SA6    A1+B1       TSCR(B7+B1)
          RJ     GNA         GET BROTHER OF THIS ENTRY
          SA6    A1          TSCR(B7) 
          ZR     B7,GTD8     IF PATRIARCH 
          SA1    A1-B1       TSCR(B7-B1)
          NZ     X1,GTD8     IF THERE ARE MORE ANCESTORS FOR TSCR(B7) 
          SB2    B7-B1
          SB2    B2+B2
          SB3    B2+B1
          SA1    LINE 
          RJ     RPC         REMOVE * ?* IF NO MORE ANCESTORS 
 GTD8     SB2    B7+B7
          SB3    B2+9 
          SA1    =2H ?
          RJ     RPC         ADD * ?* WHERE *_NAME * WAS
          SB7    B7+B1       TRY NEXT GENERATION
          EQ     GTD11
  
 GTD9     LE     B7,GTD2     IF PATRIARCH HAS NO ANCESTORS
          SX2    B7-B1
          SA1    X2+B4       TSCR(B7-B1)
          ZR     X1,GTD10    IF NO MORE BROTHERS TRY A CLOSER ANCESTOR
          SX6    X1 
          SA6    A1+B1       TSCR(B7) 
          SB2    X1+2        START HERE 
          SA2    X1+B5       TSEG(TSCR(B7-B1)) CONTAINS FATHER INDEX
          SX1    X2 
          AX1    3
          RJ     GNA         GET NEXT ANCESTOR OR  0
          SA6    A1          TSCR(B7-B1)
          SB2    B7+B7
          SB3    B2+9 
          SA1    LINE 
          RJ     RPC         REMOVE *_NAME* 
          EQ     GTD11
  
 GTD10    SB7    B7-B1
          SB2    B7+B7
          SB3    B2+9 
          SA1    LINE 
          RJ     RPC         REMOVE *_NAME* 
          LE     B7,GTD2     IF END OF TREE 
          EQ     GTD9        TRY LOWER LEVEL
  
 GTD11    SX1    LINE 
          RJ     WTL         WRITE LINE TO OUTPUT FILE
          EQ     GTD5 
  
 GTD12    RJ     AMU=        ACCUMULATE MEMORY USED 
          SX6    B0 
          SA6    TSCR+1      CLEAR *TSCR* 
          PRINT  (=2L  )
          RJ     RPD
          EQ     GTD
  
 GTDA     CON    0           INDEX OF CURRENT PATRIARCH 
 GTDB     CON    0           CURRENT LEVEL
 GTDC     CON    0           INDEX OF NEXT PATRIARCH ELSE NEGATIVE
 GTDD     DATA   40H          ==============================
          DATA   40H========================================
          DATA   12C============   END OF LEVEL SEPARATOR 
 GTDE     DATA   C/          TREE DIAGRAM./ 
 LINE     DATA   40H
          DATA   40H
          DATA   40H
          DATA   13C               END OF TREE DIAGRAM LINE (132 CHAR.) 
 MST      SPACE  4,8
**        MST - MOVE SEGMENTS FROM TABLE *TSCR1* TO *TSEG*. 
* 
*              THE SEGMENT NAMES IN *TSCR1* ARE SCANED AND ADDED TO 
*         THE FRONT OF *TSEG* IN THE ORDER EXPECTED BY *SEGRES*.
*         AFTER THIS IS DONE THE OTHER ENTRIES IN *TSEG* WHICH CONTAIN
*         INDICES INTO *TSCR1* OR *TSEG* MUST BE MODIFIED TO REFERENCE
*         THE CORRECT BLOCK, PROGRAM OR SEGMENT.
* 
*         ENTRY  *NS* = NUMBER OF SEGMENTS * 2 IN *TSCR1*.
*                *RI* = INDEX OF ROOT SEGMENT IN *TSCR1*. 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ATS=, SMS=, ASE, AMU=. 
  
  
 MST      PS                 ENTRY/EXIT 
          SMSG   DBG2 
          SA1    NS 
          SB6    X1          (B6) = 2* NUMBER OF SEGMENTS 
          ALLOC  TSEG,X1,FRONT
          SB5    X2          (B5) = FWA OF *TSEG* 
          SB7    B0          (B7) = INDEX OF NEXT ENTRY TO ADD IN *TSEG*
          SA1    TSCR1
          SA2    A1+B1
          SB2    X1          (B2) = FWA OF *TSCR1*
          SB3    X2          (B3) = LENGTH OF *TSCR1* 
          SA4    RI 
          SA1    X4+B2       MOVE ROOT SEGMENT FIRST
          SA2    A1+B1
          MX0    42 
          SX3    B0          INDEX TO FATHER
          SX5    B0          (X5) = CURRENT LEVEL 
          SA0    B0          (A0) = CURRENT ENTRY FOR FINDING ANCESTORS 
 MST1     RJ     ASE         ADD SEGMENT ENTRY TO TABLE 
 MST2     GE     B7,B6,MST8  IF DONE WITH MOVE
          SX1    A0+B1
          SA1    X1+B5       DEFINITION OF CURRENT SEGMENT
          SB4    B0          (B4) = CURRENT POINTER IN *TSCR1*
          SX1    X1 
          ZR     X1,MST5     IF NO ANCESTORS FOR THIS SEGMENT 
 MST3     GE     B4,B3,MST5  IF NO MORE ANCESTORS FOR THIS SEGMENT
          SA1    B2+B4
          SA2    A1+B1
          SX4    X1-77777B
          SB4    B4+2 
          ZR     X4,MST3     IF THIS IS A PATRIARCH 
          MI     X2,MST3     IF A TREE ENTRY OR ENTRY ALREADY PROCESSED 
          SA3    X1+B2       FATHER IN *TSCR1*
          SA4    A0+B5       FATHER IN *TSEG* 
          BX4    X3-X4       COMPARE NAMES
          BX4    X0*X4
          NZ     X4,MST3     IF FATHER IS NOT THE ONE WE WANT 
          SA3    A3+B1
          SX3    X3          INDEX OF FATHER IN *TSEG*
          NZ     X3,MST4     IF NOT A SON OF ROOT SEGMENT 
          SX4    B7-2 
          NZ     X4,MST3     IF NOT ELDEST SON TREAT AS PATRIARCH 
 MST4     RJ     ASE         ADD SEGMENT ENTRY TO *TSEG*
          EQ     MST3 
  
 MST5     SA0    A0+2        USE NEXT ENTRY IN *TSEG* 
          SX3    77777B      FIRST PATRIARCH ON LEVEL 
          SX6    A0-B7
          MI     X6,MST2     IF THERE ARE MORE SEGMENTS TO THIS TREE
          SB4    B0 
 MST6     GE     B4,B3,MST7  IF NO MORE PATRIARCHS ON THIS LEVEL
          SA1    B2+B4
          SA2    A1+B1
          SB4    B4+2 
          MI     X2,MST6     IF A TREE ENTRY OR ENTRY ALREADY PROCESSED 
          SX4    X2 
          IX4    X4-X5
          NZ     X4,MST6     IF THIS SEGMENT IS ON A DIFFERENT LEVEL
          SX6    X1-77777B
          ZR     X6,MST1     IF A PATRIARCH 
          SX4    X1+B2       ADDRESS OF FATHER IN *TSCR1* 
          SA4    X4+B1
          PL     X4,MST6     IF *TSCR1* ENTRY NOT IN *TSEG* YET          LDR0233
          SX4    X4          *TSEG* INDEX OF FATHER                      LDR0233
          NZ     X4,MST6     IF THIS IS NOT A SON OF ROOT 
          EQ     MST1        ADD THIS PATRIARCH AND ITS ANCESTORS 
  
 MST7     SX5    X5+B1       TRY NEXT LEVEL 
          SB4    B0 
          SX3    B0          NOT FIRST PATRIARCH ON LEVEL 
          EQ     MST6 
  
 MST8     SB7    B6 
          SA1    TSEG+1 
          MX3    15 
          SB4    X1          (B4) = LENGTH OF *TSEG*
          LX3    18 
          SB3    B1 
          MX7    12 
 MST8A    SA1    B5+B3
          BX6    X7*X1       CLEAR ANCESTOR BIT FROM SEGMENT DEFINITION 
          SB3    B3+2 
          SA6    A1 
          LT     B3,B6,MST8A  IF MORE SEGMENTS TO *TSEG*
 MST9     GE     B7,B4,MST12 IF ALL ENTRIES HAVE BEEN CONVERTED 
          SA1    B5+B7
          SA2    A1+B1
          BX6    -X3*X1 
          LX2    59-46
          BX7    X3*X1
          BX4    X7-X3
          LX7    -3 
          SB7    B7+2 
          MI     X2,MST11    IF INDEX IS WITHIN *TSEG*
          ZR     X4,MST10    IF INDEX IS 77777B ASSIGN TO ROOT
          SX4    X7+B2
          SA4    X4+B1       *TSCR1* DEFINITION 
          SX2    X4          NEW *TSEG* INDEX 
          LX2    3
          BX6    X6+X2
 MST10    SA6    A1 
          EQ     MST9 
  
 MST11    MX6    42 
          LX2    46-59
          SX1    X2+B6       NEW INDEX
          BX6    X6*X2
          BX6    X6+X1
          SA6    A2 
          EQ     MST9 
  
 MST12    RJ     AMU=        ACCUMULATE MEMORY USED 
          SX6    B0 
          SA6    TSCR1+1     CLEAR *TSCR1*
          EQ     MST
 RDI      SPACE  4,8
**        RDI - READ DIRECTIVE INPUT. 
* 
*              THIS ROUTINE READS THE SEGLOAD DIRECTIVES FROM THE FILE
*         SPECIFIED BY THE *SEGLOAD* *I* PARAMETER.  FIRST THE CIO
*         BUFFER IS DIVIDED INTO TWO BUFFERS.  ONE FOR FET *L* TO READ
*         THE DIRECTIVES AND THE OTHER FOR FET *O* TO PRINT THE 
*         DIRECTIVES.  THIS WILL REMAIN THE CASE THROUGHOUT THE 
*         INITIALIZATION.  EACH INPUT CARD (EXCEPT THOSE WITH */* IN
*         COLUMN 1) IS LISTED UNLESS THE *LO* PARAMETER ON THE *SEGLOAD*
*         CONTROL CARD OR THE GLOBAL MAP IS OFF.  CARDS BEGINNING WITH
*         */* CAUSES A PAGE EJECT.  BLANK CARDS AND THOSE BEGINNING 
*         WITH -*- ARE TREATED AS COMMENT CARDS.  CARDS BEGINNING 
*         WITH *,* ARE CONTINUATION CARDS.  THE VERB FIELD IS CHECKED 
*         WITH KNOWN DIRECTIVES AND THE APPROPRIATE DIRECTIVE PROCESSOR 
*         IS CALLED.
* 
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ERR, SMS=, SETFET=, CIO=, HEADER, WOF, RDO=, READCI, 
*                GNE, AND ALL DIRECTIVE  PROCESSORS.
  
  
 RDI      PS                 ENTRY/EXIT 
          SMSG   DBG1 
          SETFET L,SEGIII,CODED 
          SA1    L+1
          SA2    L+4
          SX6    X1+IP.LBUF/2 
          BX7    X2 
          SA6    A2          RESET LIMIT IN FET L 
          SA7    O+4         SET LIMIT IN FET O 
          SA6    O+1         SET FWA IN FET O 
          READ   L
          SETFET O,GLOBLFN,CODED
          MX6    0
          SA6    PGPAR
          GETPAGE PGPAR      GET JOB PAGE PARAMETERS
          SA1    PGPAR
          MX0    -8 
          AX1    12          POSITION FOR *PW*
          SA2    PGWID
          NZ     X2,RDI.2    IF ALREADY SPECIFIED 
          BX6    -X0*X1 
          SA6    A2 
 RDI.2    AX1    8           POSITION FOR *PS*
          SA2    PGSIZ
          BX6    -X0*X1 
          NZ     X2,RDI.4    IF *PS* ALREADY SPECIFIED
          SA6    A2 
 RDI.4    AX1    8           POSITION FOR *PD*
          MX0    -4 
          SA2    PRDEN
          NZ     X2,RDI.6    IF *PD* ALREADY SPECIFIED
          BX6    -X0*X1 
          SA6    A2 
 RDI.6    RJ     SPD         SET PRINT DENSITY
          RJ     HEADER      SET UP PAGE HEADER 
          PRINT  RDIA 
          PRINT  (=2L  )
          SX6    B0 
          SA6    /LOADC/CFIRST
 RDI1     SA1    /LOADC/CFIRST
          MX6    0
          SA6    A1 
          SX6    -2 
          SA6    BL          SKIP LEADING BLANKS
          NZ     X1,RDI2     IF CARD ALREADY READ 
          READO  L
          SA6    /READ/CDIMAGE
          SB6    A6+B1
          NZ     X1,RDI8     IF EOR DETECTED
          RJ     /LOADC/READCI     FIND LENGTH OF CARD IMAGE
 RDI2     SA1    /READ/CDIMAGE
          MX6    -6 
          LX1    6
          SA6    IN          FLAG FOR INPUT FILE NOT EMPTY
          BX5    -X6*X1      GET FIRST CHARACTER
          SX6    X5-1R/ 
          NZ     X6,RDI3     IF NOT A / IN COL1 
          SA1    PGSIZ
          BX6    X1 
          SA6    /LOADM/LC
          EQ     RDI1 
  
 RDI3     PRINT  /READ/LINE 
          SA2    EF 
          NZ     X2,RDI1     IF END HAS BEEN ENCOUNTERED
          SX6    X5-1R* 
          SX7    X5-1R, 
          ZR     X6,RDI1     IF A COMMENT 
          ZR     X7,RDI1     IF A CONTINUATION OF COMMENT FIELD 
          SA1    /READ/CDIMAGE+7
          MX6    12 
          BX6    X6*X1
          SA6    A1          CLEAR COLUMNS 73-80
          SA1    /READ/CDIMAGE
          SX6    A1 
          SA6    /LOADC/CCWA CURRENT WORD OF CARD IMAGE 
          SA6    A6+B1       FWA OF CARD IMAGE
          MX6    0
          SA6    A6+B1       CHARACTERS USED
          SA6    A6+B1       LITERAL FLAG 
          SA6    A6+B1       1ST TIME FLAG
          SA6    A6+B1       CHARACTER SAVED FLAG 
          SA2    =2L
          MX3    12 
          BX1    X3*X1
          IX6    X1-X2
          SA6    LB          SET TO ZERO IF NO LABEL
          ZR     X6,RDI4     IF LABEL FIELD IS NOT PRESENT
          RJ     GNE         SET NEXT ENTRY 
          NZ     B7,RDI14    IF LABEL TERMINATED BY *(-),*
          BX6    X5 
          SA6    LB 
 RDI4     RJ     GNE         GET VERB FIELD 
          GT     B7,RDI6     IF VERB TERMINATED BY *(),-* 
          MX7    42 
          SB6    B0 
          SB3    LVERBS 
          ZR     X5,RDI1     IF A BLANK CARD IGNORE 
 RDI5     SA1    VERBS+B6 
          SB6    B6+B1
          BX2    X7*X1
          IX2    X2-X5
          ZR     X2,RDI7     IF VERB MATCHES
          LT     B6,B3,RDI5  IF NOT END OF TABLE
 RDI6     SB3    ERR403      UNRECOGNIZABLE DIRECTIVE 
          EQ     RDI13
  
 RDI7     SB4    X1 
          SX6    -B1
          SA6    BL 
          JP     B4 
  
 RDI8     BSS    0
  
 TT1      IFNOS 
          MI     X1,RDI8.1   IF AN EOF OCCURRED 
          SA2    L+1         FETCH DEVICE TYPE FROM FET 
          SX1    2RTT        *TT* FOR CONNECTED FILE
          MX3    12 
          BX3    X3*X2
          LX3    12 
          IX1    X1-X3       ZERO IF CONNECTED
          NZ     X1,RDI8.1   NOT A TERMINAL 
          READ   L           READ AGAIN 
          EQ     RDI1        CRACK THE CARDS
  
 RDI8.1   BSS    0
 TT1      ENDIF 
  
          SA1    IN 
          NZ     X1,RDI9     IF INPUT FILE WAS NOT EMPTY
          ERROR  CAT,SEGERR0 ---- INPUT FILE EMPTY OR MISPOSITIONED 
  
  
 RDI9     SA1    EF 
          NZ     X1,RDI      RETURN IF END ENCOUNTERED
          SB3    ERR4401     END DIRECTIVE MISSING
          SA1    NE          INCREMENT ERROR COUNT
          RJ     ERR         PROCESS ERROR
          EQ     RDI
          SPACE  4,8
**        DIRECTIVE PROCESSORS RETURN HERE. 
* 
*              DIRECTIVE PROCESSORS ENTER HERE TO TERMINATE A CARD
*         EITHER NORMALLY OR WITH AN ERROR. 
  
  
 RDI10    SA1    /LOADC/CSAVE 
          ZR     X1,RDI1     IF NAMES ARE .LE. 7 CHAR.
          MX6    0
          SA6    A1 
          SB3    ERR4400     NAME TRUNCATED TO 7 CHAR.
          SA1    NE          INCREMENT ERROR COUNT
          RJ     ERR         PROCESS ERROR
          EQ     RDI1 
  
 RDI11    SB3    ERR406      TREE, SEGMENT OR BLOCK NAME CONFLICT 
          EQ     RDI13
  
 RDI12    SB3    ERR405      PARAMETER USED ON LOWER LEVEL
 RDI13    MX0    42 
          BX1    X0*X5
          RJ     SFN=        SPACE FILL NAME
          SA1    B3+2 
          BX1    -X0*X1      SAVE * - * 
          BX6    X0*X6
          BX6    X6+X1
          SA6    A1          ADD NAME TO ERROR MESSAGE
          EQ     RDI17
  
 RDI14    SB3    ERR402      ILLEGAL SEPARATOR
          EQ     RDI17
  
 RDI15    SB3    ERR400      UNBALANCED PARANS. 
          EQ     RDI17
  
 RDI16    SB3    ERR401      MISSING PARAMETER
 RDI17    SA1    FE          SET ERROR FLAG 
          MX7    0
          SA7    NP 
          RJ     ERR         PROCESS ERROR
          EQ     RDI10
  
 RDIA     DATA   C/          SEGLOAD DIRECTIVES./ 
          TITLE  SEGMENT GENERATION - SEGLOAD DIRECTIVE PROCESSORS. 
 END      SPACE  4,8
**        PROCESS END DIRECTIVE.
* 
*                END  NAME,...,NAME 
* 
*              THIS DIRECTIVE FLAGS THE END OF SEGMENT DIRECTIVES.
*         ANY CARDS AFTER THIS DIRECTIVE WILL BE TREATED AS COMMENTS. 
*         THE NAMES SPECIFIED IF ANY ARE ADDED TO THE END OF *TREQ* TO
*         BE PROCESSED LATER AS TRANSFER NAMES. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 2, 6.
*                B - NONE.
*                A - 6. 
*         CALLS  GNE, ADW=. 
  
  
 END      SX6    B1 
          SA6    EF 
          MI     B7,RDI10    IF NO ENTRY POINTS GIVEN 
          RJ     GNE         GET NEXT ENTRY OR EOL
          NZ     X5,END2     IF A PARAMETER IS PRESENT                   LDR0188
          MI     B7,RDI10    IF NO ENTRY POINTS 
          EQ     RDI16       IF PARAMETER MISSING                        LDR0188
  
 END1     RJ     GNE         GET ENTRY POINT NAME 
          ZR     X5,RDI16    IF MISSING PARAMETER 
 END2     ADDWRD TREQ,X5
          SX2    B7-2 
          ZR     X2,END1     IF *,* IS SEPARATOR
          GE     B7,B1,RDI14 IF ILLEGAL TERMINATOR USED 
          EQ     RDI10
 COMMON   SPACE  4,10 
**        PROCESS COMMON DIRECTIVE. 
* 
*                COMMON NAME,...,NAME 
* 
*             THE CM COMMON BLOCKS GIVEN IN THE SPECIFICATION FIELD 
*         ARE TO BE TREATED AS GLOBAL -SAVE BLOCKS AND WILL BE MOVED
*         TO THE NEAREST COMMON ANCESTOR OF THE PROGRAMS WHICH CONTAIN
*         THE COMMON BLOCK. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 4, 6.
*                B - NONE.
*                A - 6. 
*         CALLS  GNE, ECD.
  
  
 COMMON   MI     B7,COMMON2  IF NO SPECIFICATION FIELD
          RJ     GNE         GET NEXT ENTRY OR END-OF-LINE
          NZ     X5,COMMON1A  IF A PARAMETER IS PRESENT 
          MI     B7,COMMON2  IF NO SPECIFICATION FIELD
          EQ     RDI16       PARAMETER MISSING
  
 COMMON1  RJ     GNE         GET NEXT PARAMETER 
          ZR     X5,RDI16    IF PARAMETER MISSING 
 COMMON1A RJ     ECD         ENTER COMMON DEFINITION
          LE     B7,B1,RDI10 IF END OF CARD 
          SX4    B7-2 
          ZR     X4,COMMON1  IF , IS SEPARATOR
          EQ     RDI14       ILLEGAL SEPARATOR
  
 COMMON2  SX6    B1 
          SA6    ALLCOM 
          EQ     RDI10       PROCESS NEXT DIRECTIVE 
 EQUAL    SPACE  4,8
**        PROCESS EQUAL DIRECTIVE 
* 
*         LABEL  EQUAL  NAME,...,NAME 
* 
*              THIS DIRECTIVE MAKES ALL REFERENCES TO THE CM COMMON 
*         BLOCKS SPECIFIED IN THE SPECIFICATION FIELD EQUIVALENT TO 
*         THE GLOBAL BLOCK *LABEL*.  THE BLOCK ENTRIES IN *TSEG* HAVE 
*         THE FORMAT. 
* 
*         VFD    42/NAME,15/0,3/1 
*         VFD    1/R,12/0,1/Q,1/0,21/0,24/PRU 
* 
*         NAME   = BLOCK NAME.
*         R      = 1 IF BLOCK UNREFERENCED. 
*         Q      = 1 FOR EQUAL BLOCKS.
*         PRU    = INDEX OF DEFINITION OF GLOBAL BLOCK ENTRY. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 0, 1, 2, 3, 4, 5, 6. 
*                B - 6. 
*                A - 1, 4, 5, 6.
*         CALLS  ADW=, GNE, MES.
  
  
 EQUAL    MI     B7,RDI16    IF MISSING PARAM 
          SA5    LB 
          ZR     X5,RDI16    IF  MISSING PARAM
          SX6    B1 
          MX0    43 
          SA1    TSEG 
          LX0    1
          BX6    X6+X5       NAME + BLOCK BIT 
          RJ     MES         FIND BLOCK IN TSEG 
          MI     X2,EQUAL1   IF BLOCK NOT IN TSEG 
          IX3    X1+X2
          SA4    X3+B1
          LX4    59-46
          MI     X4,RDI11    IF  BLOCK NAME CONFLICT
          SB6    X2 
          EQ     EQUAL2 
  
 EQUAL1   SX6    B1 
          SX4    77777B 
          BX6    X5+X6       NAME + BLOCK BIT 
          LX4    3
          BX1    X4+X6       NAME + BLOCK BIT + INDEX 
          SA4    TSEG+1      (B6) = CURRENT *TSEG* INDEX
          SB6    X4 
          SX2    B1          R=1, G=0, E=0
          LX2    59 
          RJ     AET         ADD ENTRY TO *TSEG*
 EQUAL2   RJ     GNE         GET NEXT PARAM 
          ZR     X5,RDI16    IF NO PARAMETER
          SA1    TSEG 
          SX6    B1 
          BX6    X6+X5
          RJ     MES         FIND BLOCK IN TSEG 
          NG     X2,EQUAL3   IF BLOCK NOT IN TSEG 
          IX3    X1+X2
          SA3    X3 
          SA4    A3+B1
          LX4    59-46
          PL     X4,RDI11    IF NOT EQUAL 
          AX3    3
          MX6    -15
          BX3    -X6*X3 
          SX6    B6 
          IX6    X3-X6
          NZ     X4,RDI11    IF NOT EQUAL TO SAME BLOCK 
          EQ     EQUAL4 
  
 EQUAL3   BX1    X6          (X1) = WORD 0 OF *TSEG* ENTRY
          SX2    40002B      R=1, Q=1 
          LX2    59-14
          SX3    B6+B1
          BX2    X2+X3       ADD INDEX+1 OF EQUATED BLOCK 
          RJ     AET         ADD ENTRY TO *TSEG*
 EQUAL4   LE     B7,B1,RDI10 IF END-OF-CARD 
          SX4    B7-2 
          ZR     X4,EQUAL2   IF , IS SEPARATOR
          EQ     RDI14       IF ILLEGAL SEPARATOR USED
 GLOBAL   SPACE  4,8
**        PROCESS GLOBAL DIRECTIVE. 
* 
*         LABEL  GLOBAL  NAME,...,NAME-SAVE 
* 
*              THE CM COMMON BLOCKS GIVEN IN THE SPECIFICATION FIELD
*         ARE ASSIGNED TO THE SEGMENT *LABEL*.  IF *LABEL* IS NOT 
*         PRESENT THE BLOCKS ARE ASSIGNED TO THE ROOT SEGMENT.  IF THE
*         OPTIONAL PHRASE *-SAVE* APPEARS IN THE DIRECTIVE THEN ALL 
*         BLOCKS NAMED WILL BE SAVED AND RESTORED DURING EXECUTION. 
*         AN ENTRY IS ADDED TO *TSEG* FOR EACH NAME IN THE SPECIFICATION
*         FIELD AND ITS FORMAT IS.
* 
*         VFD    42/NAME,15/TSEG,3/1
*         VFD    12/0,1/S,1/0,1/G,21/7777776B,24/0
* 
*         NAME   = BLOCK NAME.
*         TSEG   = INDEX OF SEGMENT IN *TSCR1* OWNING BLOCK.
*         S      = 1 IF *-SAVE* APPEARED ON THE DIRECTIVE.
*         G      = 1 FOR GLOBAL BLOCKS. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 0, 1, 3, 4, 5, 6, 7. 
*                B - 2, 4, 5, 6.
*                A - 1, 3, 4, 5, 6. 
*         CALLS  ADW=, GNE, MES.
  
  
 GLOBAL   SA5    LB 
          MI     B7,RDI16    IF MISSING BLOCK NAMES 
          SB4    B0          SAVE FLAG (1 = *-SAVE* APPEARED) 
          SB5    B0          BACKWARD LINK INDEX
          ZR     X5,GLOBAL1  IF NO LABEL GIVEN
          MX0    42 
          BX6    X5 
          SA1    TSCR1
          RJ     MES         FIND SEGMENT NAME
          PL     X2,GLOBAL2  IF ENTRY IN TABLE
          ADDWRD TSCR1,X5 
          MX1    1
          LX1    59 
          SB6    X4          INDEX INTO TABLE 
          ADDWRD A2,X1
          EQ     GLOBAL3
  
 GLOBAL1  SB6    77777B      ASSIGN TO ROOT SEGMENT 
          EQ     GLOBAL3
  
 GLOBAL2  SA1    TSCR1
          IX3    X1+X2
          SA4    X3+B1
          MI     X4,RDI11    IF TREE NAME GIVEN 
          SB6    X2 
 GLOBAL3  RJ     GNE         GET NEXT ENTRY 
          ZR     X5,RDI16    IF MISSING PARAMETER 
          SA1    TSEG 
          SX6    B1 
          BX6    X5+X6       NAME + BLOCK BIT 
          MX0    43 
          LX0    1
          RJ     MES         FIND BLOCK IN TSEG 
          SB2    X1          SAVE FWA OF *TSEG* 
          MI     X2,GLOBAL4  IF ENTRY NOT FOUND 
          IX3    X1+X2
          SA3    X3 
          SA4    A3+B1
          MX6    -15
          AX3    3
          LX4    59-46
          BX3    -X6*X3 
          SX6    B6 
          MI     X4,RDI11    IF *EQUAL* BLOCK 
          LX4    46-45
          PL     X4,GLOBAL7  IF UNASSIGNED YET
          IX3    X3-X6
          NZ     X3,RDI11    IF BLOCK GLOBAL TO ANOTHER SEGMENT 
          LX4    45-59       RESTORE DEFINITION WORD
          SX1    X4          OLD LINK INDEX IF ANY
          SX6    B5 
          BX6    X6+X4
          NZ     X1,GLOBAL6  IF BLOCK APPEARS TWICE IN DIRECTIVE
          SB5    A4-B2       NEW BACKWARD INDEX 
          SA6    A4          ADD BACKWARD LINK INDEX TO DEFINITION
          EQ     GLOBAL6
  
 GLOBAL4  SX6    B1 
          BX6    X5+X6
          SX1    B6 
          LX1    3
          BX1    X1+X6       NAME + INDEX + BLOCK BIT 
          MX2    21          SET G = 1 AND LENGTH = -1
          LX2    -14
          SX3    B5 
          BX2    X2+X3       ADD BACKWARD LINK INDEX TO DEFINITION
          RJ     AET         ADD ENTRY TO *TSEG*
          SB5    X4          (B5) = NEW BACKWARD LINK INDEX 
          SX1    B1 
          LX1    17-0 
          BX5    X1+X5       SET GLOBAL BIT 
          RJ     ECD         ENTER COMMON DEFINITION IN *TCOM*
 GLOBAL6  LE     B7,GLOBAL8  IF END-OF-CARD 
          SX4    B7-2 
          ZR     X4,GLOBAL3  GET NEXT FIELD IF *,*
          SB2    B7-4 
          NZ     B2,RDI14    IF ILLEGAL SEPARATOR 
          RJ     GNE         GET *SAVE* 
          SA1    =0LSAVE
          SB4    B1          SET *-SAVE* FLAG 
          BX6    X1-X5
          ZR     X6,GLOBAL6  IF *SAVE* PRESENT
          EQ     RDI14       *-* WAS USED AS SEPARATOR
  
 GLOBAL7  LX6    3
          BX6    X5+X6
          SX1    B1 
          BX6    X6+X1
          SA6    A3          ADD INDEX TO DEFINED BLOCK ENTRY 
          MX6    21          SET LENGTH = -1
          BX6    X6+X4
          LX6    45-59       ADD G=1
          MX7    1
          BX6    -X7*X6      CLEAR *R* BIT
          SX3    B5 
          SB5    A4-B2       NEW BACKWARD LINK INDEX
          BX6    X6+X3       ADD BACKWARD LINK INDEX TO DEFINITION
          SA6    A4          RESTORE *TSEG* ENTRY 
          EQ     GLOBAL6
  
 GLOBAL8  SA1    TSEG        (X1) = FWA OF *TSEG* 
          SX3    B4 
          LX3    47 
 GLOBAL9  ZR     B5,RDI10    IF END OF BACKWARD SCAN
          SA2    X1+B5       GET DEFINITION OF BLOCK
          MX7    -24
          SB5    X2          NEW BACKWARD INDEX 
          BX6    X7*X2       REMOVE BACKWARD INDEX IN DEFINITION
          BX6    X6+X3       ADD *V* BIT IF ANY 
          SA6    A2 
          EQ     GLOBAL9
 INCLUDE  SPACE  4,8
**        PROCESS INCLUDE DIRECTIVE.
* 
*         LABEL  INCLUDE  NAME,...,NAME 
* 
*              THIS DIRECTIVE DIRECTS THE LOADER TO LOAD SPECIFIED
*         PROGRAMS IN THE SEGMENT SPECIFIED BY *LABEL*.  IF *LABEL* 
*         IS OMITTED THE PROGRAMS ARE ASSIGNED TO THE ROOT SEGMENT. 
*         THE PROGRAMS GIVEN BY *NAME* ARE INSERTED IN *TUSEP* AND HERE-
*         AFTER TREATED AS *USEP* REQUESTS.  THERE IS ALSO AN ENTRY 
*         ADDED TO *TSEG* DEFINING THE OWNER OF THIS PROGRAM, ITS FORMAT
*         IS. 
* 
*         VFD    42/NAME,15/TSEG,3/0
*         VFD    1/R,59/0 
* 
*         NAME   = PROGRAM NAME.
*         TSEG   = INDEX INTO *TSCR1* OF SEGMENT OWNING PROGRAM.
*         R      = 1 FOR PROGRAM UNDEFINED YET. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 0, 1, 3, 4, 5, 6.
*                B - 6. 
*                A - 1, 4, 5. 
*         CALLS  ADW=, APN, GNE, MES. 
  
  
 INCLUDE  MI     B7,RDI16    IF NO PARAMETERS 
          SA5    LB 
          MX0    42 
          BX6    X5 
          SA1    TSCR1
          ZR     X5,INCLUDE3 IF NO LABEL SPECIFIED
          RJ     MES         MASKED EQUALITY SEARCH 
          PL     X2,INCLUDE1 IF ENTRY IN TABLE
          ADDWRD TSCR1,X5 
          MX1    1
          SB6    X4          INDEX IN TABLE 
          LX1    58-59       SET U=1
          ADDWRD A2,X1
          EQ     INCLUDE2 
  
 INCLUDE1 SA1    TSCR1
          IX3    X1+X2
          SA4    X3+B1
          MI     X4,RDI11    IF TREE NAME GIVEN 
          SB6    X2          SAVE INDEX 
 INCLUDE2 RJ     GNE         GET NEXT ENTRY 
          ZR     X5,RDI16    IF NO PARAMETER GIVEN
          RJ     APN         ADD PROGRAM NAME TO *TUSEP*
          SX6    B6 
          LX6    3
          BX1    X6+X5       NAME + INDEX 
          MX2    1
          RJ     AET         ADD ENTRY TO *TSEG*
          SX4    B7-2 
          ZR     X4,INCLUDE2 IF ANOTHER PARAMETER COMING
          LT     B7,B1,RDI10 IF BLANK OR END-OF CARD
          EQ     RDI14       IF ILLEGAL SEPARATOR USED
  
 INCLUDE3 SB6    77777B 
          EQ     INCLUDE2    ASSIGN TO ROOT SEGMENT 
 LEVEL    SPACE  4,8
**        PROCESS LEVEL DIRECTIVE.
* 
*                LEVEL
* 
*              THIS DIRECTIVE DIVIDES MEMORY AND ALLOWS TREES TO BE 
*         LOCATED SO THAT THEY ARE INDEPENDENT AND NEVER OVERLAY EACH 
*         OTHER.  IF A LEVEL DIRECTIVE OCCURS BEFORE ANY TREE DIRECTIVE 
*         HAS BEEN ENCOUNTERED THE DIRECTIVE IS IGNORED.  THE LABEL 
*         AND SPECIFICATION FIELDS ARE IGNORED. 
* 
*         EXIT   TO *RDI*.
*         USES   X - 1, 2, 3, 4, 6. 
*                B - NONE.
*                A - 1, 2, 3, 4, 6. 
  
  
 LEVEL    SA1    LN          INCREMENT LEVEL NUMBER 
          SA2    TRFLAG      CHECK IF TREE DIRECTIVE ENCOUNTERED
          ZR     X2,RDI10    IF NO TREE STATEMENTS YET
          SX6    B0 
          SA6    TRFLAG            RESET TREE ENCOUNTERED FLAG
          SX6    X1+B1
          SA6    A1 
          EQ     RDI10
  
 TRFLAG   CON    0           TRFLG = 1 IF VALID TREE ENCOUNTERED
 TREE     SPACE  4,8
**        PROCESS TREE DIRECTIVE. 
* 
*         LABEL  TREE  TREE-STRUCTURE 
* 
*              THE *TREE* DIRECTIVE DEFINES THE STRUCTURE OF SEGMENTS 
*         IN TREES.  THE SEGMENT NAMES SPECIFIED ARE ADDED TO *TSCR1* 
*         IF NOT ALREADY THERE (FROM *INCLUDE* OR LABEL FIELD OF
*         PREVIOUS *TREE* DIRECTIVE).  ITS FORMAT IS. 
* 
*         VFD    42/NAME,18/LINK
*         VFD    1/T,1/U,1/A,21/0,18/SCR,18/LEVEL 
* 
*         NAME   = SEGMENT NAME.
*         LINK   = INDEX OF ANCESTOR IN *TSCR1* OR 77777B.
*         T      = 1 IF THIS IS A TREE NAME.
*         U      = 0 IF DEFINED BY A *TREE* DIRECTIVE.
*         A      = 1 IF THIS SEGMENT HAS ANCESTORS. 
*         SCR    = INDEX OF PREVIOUS ANCESTOR WHEN NEXT *)* IS READ.
*         LEVEL  = LEVEL IN WHICH SEGMENT WAS DEFINED.
* 
*              THE SEGMENT NAMES ARE ADDED TO *TUSEP* BECAUSE A 
*         PROGRAM BY THAT NAME WILL BE LOADED IN THE SEGMENT WITH THE 
*         SAME NAME UNLESS DIRECTED  ELSEWHERE BY AN *INCLUDE*
*         DIRECTIVE.
* 
*         EXIT   TO *RDI*.
*         USES   ALL REGISTERS EXCEPT B1. 
*         CALLS  ADW=, GNE, MES.
  
  
 TREE     MI     B7,RDI16    IF SEGMENT NAMES MISSING 
          SB6    77777B      *-* ANCESTOR 
          SB5    B6          *(* ANCESTOR 
          SB4    B1 
          SX6    -B1
          SA6    TREEA
 TREE0    RJ     GNE         GET FIRST SEGMENT NAME 
          ZR     X5,RDI16    IF NO SEGMENT NAME GIVEN 
 TREE1    SA2    LB 
          BX7    X2-X5
          MX0    42 
          ZR     X7,RDI11    IF LABEL APPEARS IN SPEC FIELD 
          SA1    TSCR1
          BX6    X5 
          RJ     MES         FIND SEGMENT IN TABLE
          NG     X2,TREE4    IF  NAME NOT IN TABLE
          IX3    X1+X2
          SB3    X2          SAVE INDEX OF ENTRY
          SA4    A3+B1
          PL     X4,TREE3    IF ENTRY IS A SEGMENT
 TREE2    SA3    X3          OLD LINK ENTRY 
          SX6    X3-77777B
          ZR     X6,RDI11    IF TREE NAME USED BEFORE 
          SX7    B7-4 
          ZR     X7,RDI11    IF TREE HAS AN ANCESTOR - ERROR
          SX7    77777B 
          BX6    X7+X3
          SA6    A3          DESTROY OLD TREE LINK
          SX6    X3 
          IX3    X1+X6
          SA4    X3+B1       NEW LINK ENTRY 
          MI     X4,TREE2    IF LINK IS A TREE ENTRY TOO
          SA3    A4-B1       NEW LINK ENTRY WORD 0
          SX6    B6          LINK NEW ENTRY TO ITS FATHER 
          BX7    -X7*X3 
          BX6    X6+X7
          SA6    A3          RESTORE NEW LINK ENTRY 
          SA1    LN 
          SX7    X4 
          IX7    X1-X7
          NZ     X7,RDI12    IF PARAMETER USED ON LOWER LEVEL 
          EQ     TREE6
  
 TREE3    LX4    59-58       CHECK U=1
          PL     X4,RDI11    IF SEGMENT DEFINED EARLIER 
          MX6    1
          BX6    -X6*X4      REMOVE U=1 
          LX6    58-59
          SA3    LN 
          SX7    B5 
          BX6    X6+X3       ADD LEVEL
          LX7    18 
          SA3    A4-B1
          BX6    X6+X7       ADD *(* ANCESTOR 
          SX7    B6 
          SA6    A4          RESTORE WORD 1 
          BX7    X7+X3       NAME + *-* ANCESTOR
          SA7    A3 
          SX4    B7-4 
          NZ     X4,TREE6    IF SEPARATOR IS NOT *-*
          MX1    1
          LX1    57-59
          BX6    X1+X6       ADD A=1
          SA6    A4 
          EQ     TREE6
  
 TREE4    SX1    B6 
          BX1    X5+X1       NAME + *-* ANCESTOR
          ADDWRD TSCR1,X1 
          SA3    LN 
          SB3    X4 
          SX1    B0 
          SX7    B5 
          SX4    B7-4 
          LX7    18 
          NZ     X4,TREE5    IF SEPARATOR IS NOT *-*
          MX1    1
          LX1    57-59       SET A=1
 TREE5    BX1    X1+X3
          BX1    X1+X7       A BIT + LEVEL + *(* ANCESTOR 
          ADDWRD A2,X1
 TREE6    SA1    TREEA
          PL     X1,TREE7    IF NOT ROOT OF THIS TREE 
          SX6    B3 
          SB4    B0 
          SA6    A1          SAVE INDEX OF ROOT OF THIS TREE
 TREE7    LT     B7,B1,TREE9 IF END OF TREE STATEMENT 
          SX4    B7-2 
          ZR     X4,TREE12   IF SEPARATOR IS *,*
          MI     X4,RDI14    IF SEPARATOR IS *(*
          SX4    X4-2 
          MI     X4,TREE8    IF SEPARATOR IS *)*
          SB6    B3          SET *-* ANCESTOR 
          RJ     GNE         GET NEXT ENTRY 
          NZ     X5,TREE1    IF SEGMENT NAME PRESENT
          NE     B7,B1,RDI14 IF SEPARATOR IS NOT *(*
          SA1    NP 
          SB5    B6          SET *(* ANCESTOR TO *-* ANCESTOR 
          SX6    X1+B1
          SA6    A1          PARAN = PARAN +1 
          EQ     TREE0
  
 TREE8    RJ     GNE         GET NEXT ENTRY 
          NZ     X5,RDI14    IF NAME FOLLOWS *)*
          EQ     B7,B1,RDI14 IF SEPARATOR IS *(*
          SX4    B7-4 
          ZR     X4,RDI14    IF SEPARATOR IS *-*
          SA1    NP 
          ZR     X1,RDI15    IF UNBALANCED PARANS 
          SX6    X1-1 
          SA6    A1 
          SA2    TSCR1
          SX1    X2+B5
          SA4    X1+B1       GET *(* ANCESTOR ENTRY 
          AX4    18 
          SB5    X4          *(* ANCESTOR = OLD *(* ANCESTOR
          SB6    B5          *-* ANCESTOR = *(* ANCESTOR
          SX4    B7-2 
          ZR     X6,TREE11   IF THIS SHOULD BE LAST *)* 
          ZR     X4,TREE0    IF *,* IS SEPARATOR
          PL     X4,TREE8    IF *)* FOLLOWS *)* 
 TREE9    SA1    NP 
          NZ     B4,RDI16    IF NO PARAMETERS ON TREE 
          NZ     X1,RDI15    IF UNBALANCED PARANS 
          SA5    LB 
          SA1    TSCR1
          NZ     X5,TREE9A   IF LABEL 
          SX6    B1 
          SA6    TRFLAG      FLAG VALID TREE ENCOUNTERED
          EQ     RDI10
  
 TREE9A   BSS    0
          BX6    X5 
          RJ     MES         FIND LABEL IN TABLE
          MI     X2,TREE10   IF LABEL NOT IN TABLE
          IX3    X1+X2
          SA3    X3 
          BX7    -X0*X3 
          SA4    A3+B1
          MI     X4,RDI11    IF TREE DECLARED BEFORE
          SX6    X4          LEVEL OF SEGMENT ENTRY 
          LX4    59-58
          MI     X4,RDI11    IF SEGMENT UNDEFINED 
          LX4    58-57
          MI     X4,RDI11    IF SEGMENT HAS ANCESTORS 
          SA2    LN 
          IX6    X6-X2
          NZ     X6,RDI12    IF NAME USED ON LOWER LEVEL
          SA2    TREEA
          BX6    X0*X3
          BX6    X6+X2       LINK TREE TO ROOT OF NEW TREE
          SA6    A3 
          IX3    X1+X2
          SA3    X3 
          BX6    X0*X3
          BX6    X6+X7       NAME + FATHER INDEX
          SA6    A3          RESTORE ENTRY
          LX4    57-59
          MX6    1
          BX6    X6+X4       SET T=1
          SA6    A4 
          SX6    B1 
          SA6    TRFLAG      FLAG VALID TREE ENCOUNTERED
          EQ     RDI10
  
 TREE10   SA3    TREEA
          BX1    X3+X5       NAME + FATHER INDEX
          ADDWRD TSCR1,X1 
          MX1    1
          SA3    LN 
          BX1    X1+X3       T BIT + LEVEL
          ADDWRD A2,X1
          SX6    B1 
          SA6    TRFLAG      FLAG VALID TREE ENCOUNTERED
          EQ     RDI10
  
 TREE11   LE     B7,TREE9    IF BLANK OR END-OF-CARD
          EQ     RDI15       UNBALANCED PARANS
  
 TREE12   SB6    B5          *-* ANCESTOR = *(* ANCESTOR
          SA1    NP 
          ZR     X1,RDI15    IF *TREE A,B* IS GIVEN 
          EQ     TREE0
  
 TREEA    CON    -1          INDEX FOR ROOT OF CURRENT TREE 
          TITLE  SEGMENT GENERATION - INITIALIZATION SUBROUTINES. 
 APN      SPACE  4,8
**        APN - ADD PROGRAM NAME TO *TUSEP*.
* 
*         ENTRY  (X5) = NAME IN 0L FORMAT.
*         USES   X - 2, 3, 6. 
*                B - 2, 3.
*                A - 2, 3.
*         CALL   ADW=.
  
  
 APN      PS                 ENTRY/EXIT 
          SA3    TUSEP+1
          SA2    A3-B1
          SB2    X3          (B2) = LENGTH OF *TUSEP* 
          SB3    B0          (B3) = CURRENT ENTRY IN *TUSEP*
 APN1     EQ     B2,B3,APN2  IF ENTRY NOT IN *TUSEP*
          SA3    X2+B3
          SB3    B3+B1
          BX6    X5-X3
          ZR     X6,APN      IF ENTRY ALREADY IN *TUSEP*
          EQ     APN1 
  
 APN2     ADDWRD A2,X5       ADD PROGRAM NAME TO *TUSEP*
          EQ     APN
 ASE      SPACE  4,8
**        ASE - ADD SEGMENT ENTRY TO TABLE *TSEG*.
* 
*              THIS SUBROUTINE IS USED TO ADD THE SEGMENT DEFINITIONS TO
*         THE FRONT OF *TSEG* FROM THE INITIAL *TSCR1* ENTRIES. 
* 
*         ENTRY  (A1) = ADDRESS OF FIRST WORD OF *TSCR1* ENTRY. 
*                (X1) = FIRST WORD OF *TSCR1* ENTRY.
*                (A2) = A1+B1.
*                (X2) = SECOND WORD OF *TSCR1* ENTRY. 
*                (X3) = INDEX TO FATHER IN *TSEG*.
*                (X0) = MASK (MX0 42).
*                (B5) = FWA OF *TSEG*.
*                (B7) = INDEX OF WHERE TO ADD IN *TSEG*.
*         EXIT   (B7) INCREMENTED.
*         USES   X - 2, 3, 4, 6, 7. 
*                B - 7. 
*                A - 6, 7.
  
  
 ASE      PS                 ENTRY/EXIT 
          BX6    X0*X1       NAME 
          SX4    5           S=1, E=0, T=1
          LX3    3
          BX6    X6+X4
          SX7    X2          SAVE LEVEL IN *FI* FIELD 
          BX6    X6+X3
          LX7    48 
          MX4    59 
          BX3    X0*X2
          AX2    57 
          BX2    -X4*X2 
          BX7    X7+X2       ADD ANCESTOR BIT FROM *TSCR1* ENTRY
          SA6    B5+B7       ADD ENTRY TO *TSEG*
          SA7    A6+B1
          MX6    1
          SX7    B7 
          BX6    X6+X3
          BX6    X6+X7       FLAG *TSCR1* ENTRY AS USED WITH INDEX TO 
          SA6    A2 
          SB7    B7+2        SET INDEX TO NEXT ENTRY
          EQ     ASE
 CCC      SPACE  4,8
**        CCC - CHECK CONTINUATION CARD.
* 
*              THIS ROUTINE CHECKS FOR CONTINUATION CARDS ON SEGMENT
*         DIRECTIVES.  IF A CONTINUATION CARD IS PRESENT THE *GNE*
*         PARAMETERS ARE ADJUSTED AND THE CARD PRINTED ELSE A FLAG SET
*         TO INDICATE THE NEXT CARD HAS BEEN READ.
* 
*         EXIT   (B7) = -1 IF NO CONTINUATION CARD. 
*                       0 IF A CONTINUATION CARD  READ. 
*                       1 IF NOT AT COLUMN 72 YET 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 7. 
*                A - 1, 2, 6, 7.
*         CALLS  GNC, RNC, WOF. 
  
  
 CCC      PS                 ENTRY/EXIT 
          SA1    /LOADC/CCHAR 
          SA2    /READ/LTHIMAGE 
          SX3    X1-2        CHECK FOR POSITION AT COLUMN 72
          SX4    X2-8 
          SB7    B1 
          IX6    X3+X4       CHECK IF AT CHAR 2 IN WORD 8(COL 72) 
          SA1    /LOADC/CLIT
          ZR     X1,CCC2     IF NOT A LITERAL 
          NZ     X6,CCC 
CCC2      BSS    0
          SX6    B4 
          SA6    CCCA 
          RJ     RNC         READ NEXT CARD 
          SB7    -B1
          NZ     X1,CCC1     IF EOR ON READ 
          MX6    -6 
          SA1    /READ/CDIMAGE
          LX1    6
          BX6    -X6*X1 
          SX6    X6-1R, 
          NZ     X6,CCC1     IF NO CONTINUATION CARD
          MX7    0
          SA7    /LOADC/CFIRST  CLEAR LINE PRINTED FLAG 
          PRINT  /READ/LINE  PRINT DIRECTIVE
          SA1    /READ/CDIMAGE+7
          MX6    12 
          BX6    X6*X1
          SA6    A1          REMOVE COLUMNS 73-80 
          RJ     /LOADC/GNC  SKIP , 
          SA1    CCCA 
          SB7    B0 
          SB4    X1 
          EQ     CCC
  
 CCC1     SA1    /LOADC/CLIT
          ZR     X1,CCC      IF NOT IN LITERAL MODE 
          PRINT  ERR404      INCOMPLETE PARAMETER 
          SA1    FE          SET FE FLAG
          SX6    X1+B1
          SA6    A1 
          MX7    0
          SA7    /LOADC/CLIT CLEAR LITERAL FLAG 
          SA1    CCCA 
          SB7    -B1
          SB4    X1 
          EQ     CCC
  
 CCCA     BSS    1           REGISTER SAVE AREA 
 COL      SPACE  4,8
**        COL - CORRECT OUTPUT LINE.
* 
*              THIS ROUTINE REPLACES A COLUMN OF THE OUTPUT LINE BY THE 
*         GIVEN CHARACTER.  THIS IS USED TO LIST THE TREE DIAGRAM.
* 
*         ENTRY  (B2) = COLUMN  NUMBER (0,1,...)
*                (X1) = CHARACTER  IN BITS 54-59. 
*         USES   X - 1, 2, 6, 7.
*                B - 6. 
*                A - 2, 6.
  
  
 COL      PS                 ENTRY/EXIT 
          SA2    LINE+1 
          SX6    B2 
 COL1     SX6    X6-10
          MI     X6,COL2     IF THIS IS THE WORD TO MODIFY
          SA2    A2+B1
          EQ     COL1 
  
 COL2     BX6    -X6         INVERT COLUMN NUMBERS
          SB6    X6 
          SB6    B6+B6       2 * COLUMN 
          SB6    X6+B6       3 * COLUMN 
          MX7    6
          BX6    X7*X1       CHARACTER TO ADD 
          SB6    B6+B6       6* COLUMN
          LX6    X6,B6       SHIFT CHARACTER
          LX7    X7,B6       SHIFT MASK 
          BX2    -X7*X2 
          BX6    X6+X2
          SA6    A2          RESTORE WORD WITH NEW CHARACTER
          EQ     COL
 ERR      SPACE  4,8
**        ERR - PROCESS SEGMENT GENERATION ERRORS.
* 
*              IF NO DIRECTIVE LIST IS GENERATED THEN THE ERROR WLL BE
*         DAYFILED STARTING AT (B3+2).  OTHERWISE *WOF* IS CALLED TO
*         PRINT THE ERROR.
* 
*         ENTRY  (B3) = ERROR MESSAGE.
*                (A1) = *FE* OR *NE* TO BE INCREMENTED. 
*         USES   X - 1, 2, 6. 
*                B - NONE.
*                A - 1, 2, 6. 
*         CALLS  MSG=, WOF. 
  
  
 ERR      PS                 ENTRY/EXIT 
          SX6    X1+B1
          SA6    A1          INCREMENT ERROR COUNT
          SA1    SEGMAP 
          LX1    59-0 
          PL     X1,ERR1     IF NO DIRECTIVE LIST 
          PRINT  B3 
          SA2    /LOADM/LC
          R=     X6,1 
          IX6    X2+X6
          SA6    A2          INCREMENT LINE COUNT FOR *0* CARRIAGE CON. 
          PRINT  (=2L  )
          RJ     RPD
          EQ     ERR
  
 ERR1     SA1    ERRA 
          SX6    X1+B1
          SA6    A1 
          NZ     X1,ERR2     IF DAYFILE HEADER ALREADY DAYFILED 
          SA1    SEGERR1+2
          MX6    -12
          BX6    X6*X1       CLEAR *SEE MAP* FROM MESSAGE 
          SA6    A1 
          SA1    DFMFLAG
          NZ     X1,ERR1A    IF MESSAGE ALREADY ISSUED
          SX6    B1 
          SA6    A1 
          SX1    COMLDCC     COMMAND IS IN RA+70B 
          IFNOS  1
          MESSAGE X1,R       DAYFILE THE COMMAND
          IFSCOPE 1 
          MESSAGE X1,R,6     DAYFILE THE COMMAND (NOT TO TERMINAL)
 ERR1A    BSS    0
          MESSAGE SEGERR1,RCL 
 ERR2     MESSAGE B3+2,RCL
          RJ     RPD
          EQ     ERR
  
 ERRA     CON    0           NUMBER OF SEGLOAD DIRECTIVE ERRORS 
 FNP      SPACE  4,8
**        FNP - FIND NEXT PATRIARCH.
* 
*         ENTRY  *NSEGS* = NUMBER OF SEGMENT ENTRIES IN *TSEG*. 
*                (X1) = INDEX OF CURRENT PATRIARCH. 
*         EXIT   (X6) = INDEX OF NEXT PATRIARCH ELSE NEGATIVE.
*                (B5) = FWA OF *TSEG*.
*                (X7) = LENGTH OF TREE DIAGRAM FOR THE TREE.
*         USES   X - 1, 2, 3, 6, 7. 
*                B - 5, 6, 7. 
*                A - 1, 2.
  
  
 FNP      PS                 ENTRY/EXIT 
          SB7    X1 
          MX3    15 
          SA1    TSEG 
          SA2    NS 
          SB5    X1 
          SB6    X2          LENGTH OF SEGMENTS IN *TSEG* 
          LX3    18 
          SX6    -B1
          SX7    B6-B7
 FNP1     SB7    B7+2 
          GE     B7,B6,FNP   IF PATRIARCH NOT FOUND 
          SA1    B5+B7       *TSEG* ENTRY 
          SA2    A1+B1
          BX1    X3*X1
          LX1    -3 
          AX2    -12         LEVEL
          ZR     X1,FNP3     IF FATHER IS 0 
          SX1    X1-77777B
          NZ     X1,FNP1     IF FATHER IS NOT 77777B
          ZR     X2,FNP1     IF LEVEL 0 THEN THIS IS A SON OF ROOT
 FNP2     SX6    B7          INDEX OF PATRIARCH 
          SX7    B6-B7
          EQ     FNP
  
 FNP3     NZ     X2,FNP2     IF LEVEL IS NON-ZERO THEN THIS IS PATRIARCH
          EQ     FNP1 
 GNA      SPACE  4,8
**        GNA - GET NEXT ANCESTOR.
* 
*         ENTRY  (B2) = STARTING INDEX IN *TSEG* OF WHERE TO LOOK FIRST.
*                (B5) = FWA OF *TSEG*.
*                (X1) = INDEX OF FATHER IN *TSEG*.
*                *NSEGS* = NUMBER OF SEGMENT ENTRIES IN *TSEG*. 
*         EXIT   (X6) = NEXT BROTHER OF (B2) ELSE 0.
*         USES   X - 2, 3, 4, 6.
*                B - 2, 3.
*                A - 2. 
  
  
 GNA      PS                 ENTRY/EXIT 
          SA2    NS 
          MX3    15 
          SB3    X2 
          LX3    18 
          SX6    B0 
 GNA1     GE     B2,B3,GNA   IF NO MORE BROTHERS
          SA2    B5+B2       *TSEG* ENTRY 
          BX2    X3*X2
          SB2    B2+2 
          BX4    X2-X3
          LX2    -3 
          IX2    X2-X1       COMPARE FATHER NUMBERS 
          ZR     X4,GNA4     IF THIS IS PATRIARCH 
          NZ     X2,GNA1     IF FATHER DOES NOT MATCH 
          NZ     X1,GNA3     IF FATHER IS NOT ROOT SEGMENT
 GNA2     SA2    A2+B1
          AX2    -12         LEVEL
          NZ     X2,GNA      IF NOT LEVEL 0 THEN NO MORE ANCESTORS
 GNA3     SX6    B2-2 
          EQ     GNA
  
 GNA4     ZR     X1,GNA2     IF WE ARE LOOKING FOR SONS OF ROOT SEGMENT 
          EQ     GNA
 GNE      SPACE  4,8
**        GNE - GET NEXT ENTRY. 
* 
*              THIS ROUTINE EXTRACTS THE NEXT NON-BLANK FIELD FROM A
*         SEGLOAD DIRECTIVE AND RETURNS THE FIELD AND TERMINATING 
*         CHARACTER.  LEADING AND TRAILING BLANKS ARE IGNORED WHEN
*         CRACKING THE LABEL AND VERB FIELDS.  WHEN EITHER
*         END-OF-CARD OR BLANK FOLLOWING SPECIFICATION FIELD
*         SEPARATOR IS ENCOUNTERED, THE NEXT CARD IS READ, AND IF 
*         THAT CARD STARTS WITH A *,* THEN TREAT THAT CARD AS A 
*         CONTINUATION CARD.  IF AN END OF RECORD IS ENCOUNTERED
*         BEFORE A BLANK FIELD IS FOUND AN ERROR MESSAGE IS ISSUED
*         AND END-OF-CARD STATUS IS RETURNED. 
* 
*         ENTRY  CARD IMAGE READ AND *CCWA*, *CFWA*, *CCHAR*, *CLIT*, 
*                *CFIRST* AND *CSAVE* ARE SET UP. 
*         EXIT   (X5) = 42/0LSTRING,18/0
*                     *STRING*=NEXT FIELD WITH 0-7 CHARACTERS.
*                (B7) = CODE OF TERMINATOR. 
*                     -1 IF END-OF-CARD 
*                     0 IF BLANK
*                     1 IF *(*
*                     2 IF *,*
*                     3 IF *)*
*                     4 IF *-*
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 3, 7. 
*                A - 1, 2, 3, 4, 6, 7.
*         CALLS  GNC, CCC, SNC. 
  
  
 GNE      PS                 ENTRY/EXIT 
          SX6    B5 
          SX7    B6 
          SA6    GNEA        SAVE B4, B5 AND B6 
          SA7    A6+B1
          SX6    B4 
          MX5    0
          SA6    A7+B1
          SB5    B0 
          SB4    B0 
 GNE1     SA1    /LOADC/CCWA
          NG     X1,GNE7     IF END-OF-CARD ENCOUNTERED 
          RJ     /LOADC/GNC 
          SA1    /LOADC/CLIT
          NZ     X1,GNE8     IF IN LITERAL MODE 
          SX1    X6-1R
          SX2    X6-1R( 
          SB7    B0 
          ZR     X1,GNE3     IF CHARACTER IS BLANK
          SB7    B7+B1
          ZR     X2,GNE6     IF A *(* 
          SX3    X6-1R, 
          SX4    X6-1R) 
          SB7    B7+B1
          ZR     X3,GNE6     IF A *,* 
          SB7    B7+B1
          ZR     X4,GNE6     IF A *)* 
          SX1    X6-1R- 
          SB7    B7+B1
          SX2    X6-1R$ 
          ZR     X1,GNE6     IF A *-* 
          ZR     X2,GNE5     IF A *$* 
 GNE2     SX4    B4-7 
          PL     X4,GNE4     IF FIELD .GT. 7 CHAR.
          SB4    B4+B1
          LX5    6
          BX5    X5+X6       ADD CHAR. TO STRING
          EQ     GNE1 
  
 GNE3     SA2    /LOADC/CCWA
          MI     X2,GNE7     IF AT END-OF-CARD
          SA1    BL 
          NZ     B4,GNE6     IF AT LEAST ONE CHARACTER PROCESSED
          PL     X1,GNE7     IF WE DO NOT SKIP LEADING BLANKS 
          ZR     B4,GNE1     SKIP LEADING BLANKS
          EQ     GNE6 
  
 GNE4     SX6    B1 
          SA6    /LOADC/CSAVE  SET FLAG FOR FIELD TOO LARGE 
          EQ     GNE1        SKIP REMAINING CHARACTERS
  
 GNE5     SX6    B1 
          SA6    /LOADC/CLIT  FLAG FOR LITERAL MODE 
          EQ     GNE1 
  
 GNE6     SB2    10 
          SB2    B2-B4       (B2) = 6 * (10 - NO. OF CHARACTERS)
          SB2    B2+B2
          SB3    B2 
          SB2    B2+B2
          SB2    B2+B3
          LX5    X5,B2
          SA1    BL 
          SX6    X1+B1
          SA6    A1 
          SA1    GNEA        RESTORE B4,B5,B6 
          SA2    A1+B1
          SA3    A2+B1
          SB5    X1 
          SB6    X2 
          SB4    X3 
          EQ     GNE
  
 GNE7     RJ     CCC         CHECK FOR CONT. CARD 
          ZR     B7,GNE1     IF CONT CARD READ
          NE     B7,B1,GNE6  IF NO CONT. CARD 
          SB7    -B1
          EQ     GNE11       PROCESS LITERAL BLANKS TO END-OF-CARD
  
 GNE8     SX1    X6-1R$ 
          NZ     X1,GNE2     IF NOT  *$* ADD TO STRING
 GNE9     SA2    /LOADC/CCWA
          BX4    X6 
          MI     X2,GNE10    IF END-OF-CARD ENCOUNTERED 
          RJ     /LOADC/SNC  SELECT NEXT CHAR.
          SX4    X6-1R$ 
          MX7    0
          ZR     X4,GNE12    IF ANOTHER *$* 
          SA7    /LOADC/CLIT  CLEAR LITERAL MODE
          EQ     GNE1 
  
 GNE10    RJ     CCC         CHECK FOR CONTINUATION CARD
          ZR     B7,GNE9     IF A CONT. CARD
          MX6    0
          SA6    /LOADC/CLIT  CLEAR LITERAL MODE
          SB7    -B1
          EQ     GNE6 
  
 GNE11    SA1    /LOADC/CCHAR 
          SX7    X1+B1
          SA7    A1          SKIP NEXT CHARACTER
          SX7    X7-10
          SX6    1R 
          NZ     X7,GNE2     IF MORE ROOM BEFORE COLUMN 72
          SA7    A1          RESET CHAR COUNT TO ZERO 
          SA2    /READ/LTHIMAGE 
          SX7    X2+B1
          SA7    A2 
          EQ     GNE2        ADD BLANK TO NAME
  
 GNE12    RJ     /LOADC/GNC  PUT NEXT *$* IN STRING 
          EQ     GNE2 
  
 GNEA     BSS    3           REGISTER SAVE AREA 
 HEADER   SPACE  4,8
**        HEADER - SET PAGE HEADER. 
* 
*              THIS ROUTINE PLACES THE DATE AND CLOCK TIME IN THE PAGE
*         HEADER (FIRST TIME ONLY) AND THEN CALLS *WOF* TO PUT THE
*         HEADER IN THE MANAGED TABLE *TSCR*.  THIS IS SIMILAR TO THE 
*         ROUTINE *HEADER* IN *BLOADM*. 
* 
*         USES   X - 1, 2, 6, 7.
*                B - NONE.
*                A - 1, 2, 6, 7.
*         CALLS  SYS=.
  
  
 HEADER   PS                 ENTRY/EXIT 
          DATE   /LOADM/DATE
          CLOCK  /LOADM/TIME
          SA1    =20H SEGMENTED LOAD. 
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    /LOADM/PNAM
          SA7    A6+B1
          EQ     HEADER 
 MES      SPACE  4,8
**        MES - MASKED EQUALITY SEARCH. 
* 
*              THIS ROUTINE DOES A TABLE SEARCH TO MATCH PART OF THE
*         FIRST WORD OF 2 WORD TABLE ENTRIES.  THE SEARCH STARTS FROM 
*         THE FRONT OF THE TABLE. 
* 
*         ENTRY  (A1) = TABLE ADDRESS.
*                (X1) = FWA OF TABLE. 
*                (X0) = MASK. 
*                (X6) = ENTRY FOR SEARCH. 
*         EXIT   (X2) = INDEX IN TABLE IF FOUND ELSE NEGATIVE.
*         USES   X - 2, 3.
*                B - 2, 3.
*                A - 2, 3.
  
  
 MES      PS                 ENTRY/EXIT 
          SA2    A1+B1
          SB3    X2 
          SB2    B1+B1       (B2) = 2 
          MX2    60 
 MES1     ZR     B3,MES      RETURN IF NO MATCH 
          SB3    B3-B2
          SA3    X1+B3
          BX3    X3*X0
          IX3    X3-X6
          NZ     X3,MES1     IF NO MATCH
          SX2    B3 
          EQ     MES
 RNC      SPACE  4,8
**        RNC - READ NEXT CARD. 
* 
*              THE NEXT *SEGLOAD* DIRECTIVE IS READ INTO THE BUFFER 
*         STARTING AT */READ/CDIMAGE*.
* 
*         EXIT   (X1) = 0 IF NEXT CARD READ.
*         USES   X - 1, 6.
*                B - NONE.
*                A - 6. 
*         CALLS  RDW=, READCI.
  
  
 RNC      PS                 ENTRY/EXIT 
          READO  L
          SA6    /READ/CDIMAGE
          SB6    A6+B1
          NZ     X1,RNC      IF EOR ON READ 
          RJ     /LOADC/READCI
          SX6    /READ/CDIMAGE
          SA6    /LOADC/CCWA CURRENT WORD OF CARD IMAGE 
          SA6    A6+B1       FWA OF CARD IMAGE
          MX6    0
          SA6    A6+B1       CHARACTER COUNT
          SX6    B1 
          SA6    /LOADC/CFIRST  FLAG READ OF CARD WITHOUT WRITE 
          MX1    0
          EQ     RNC
 RPC      SPACE  4,8
**        RPC - REPLACE CHARACTER IN PRINT LINE.
* 
*              THIS ROUTINE REPLACES THE GIVEN CHARACTERS STARTING AT 
*         THE SPECIFIED COLUMN NUMBERS.  THIS IS USED TO GENERATE 
*         A TREE DIAGRAM. 
* 
*         ENTRY  (B2) = STARTING COLUMN NUMBER. 
*                (B3) = ENDING COLUMN NUMBER (INCLUSIVE). 
*                (X1) = WORD CONTAINING CHARACTERS TO SUBSTITUTE. 
*                       IF B3-B2+1 .GT. 10 X1 IS REPEATED.
*         USES   X - 1. 
*                B - 2. 
*                A - NONE.
*         CALLS  COL. 
  
  
 RPC      PS                 ENTRY/EXIT 
 RPC1     RJ     COL         REPLACE COLUMN 
          SB2    B2+B1
          LX1    6
          LE     B2,B3,RPC1  IF MORE COLUMNS TO REPLACE 
          EQ     RPC
 WOF      SPACE  4,8
**        WOF - WRITE OUTPUT FILE.
* 
*              THIS IS SIMILAR TO *WOF* IN *BLOADM*.  THIS ROUTINE ADDS 
*         A LINE IN *C* FORMAT TO THE OUTPUT FILE.  IT ALSO 
*         CHECKS FOR END-OF-PAGE AND STARTS A NEW PAGE WHEN NECESSARY.
* 
*         ENTRY  (X1) = ADDRESS OF NEW LINE.
*         USES   X - 1, 2, 3, 6, 7. 
*                B - NONE.
*                A - 1, 2, 3, 6, 7. 
*         CALLS  CDD=, WTC=.
  
  
 WOF      PS                 ENTRY/EXIT 
          SA3    SEGMAP 
          LX3    59-0 
          R=     X6,1 
          PL     X3,WOF      IF NO OUTPUT TO BE GENERATED 
          SA2    /LOADM/LC   INCREMENT LINE COUNT 
          BX7    X1 
          IX6    X2+X6
          SA7    WOFA        SAVE FWA OF NEW LINE 
          SA6    A2 
          SA1    PGSIZ
          IX7    X6-X1
          NG     X7,WOF1     IF NOT BOTTOM OF PAGE
          SX6    3
          SA6    A2          RESET LINE COUNT 
          SA1    /LOADM/PC   ADVANCE PAGE COUNT 
          SX6    X1+B1
          SA6    A1 
          RJ     CDD=        CONVERT PAGE NUMBER
          MX7    -12
          LX6    24 
          BX6    X7*X6
          SX1    /LOADM/TITL
          SA6    /LOADM/PAGE
          WRITEC O,X1 
          WRITEC O,(=2L  )
          WRITEC O,(=2L  )
 WOF1     SA1    WOFA 
          WRITEC O,X1 
          EQ     WOF
  
 WOFA     BSS    1           HOLDS FWA OF NEW LINE
 WTL      SPACE  4,8
**        WTL - WRITE TREE LINE.
* 
*              THIS ROUTINE WRITES ONE LINE OF THE TREE DIAGRAM.
* 
*         ENTRY  (X1) = ADDRESS OF LINE TO BE PRINTED.
*         EXIT   (B4) = FWA OF *TSCR*.
*                (B5) = FWA  OF *TSEG*. 
*         USES   X - 1, 2, 3, 7.
*                B - 4, 5.
*                A - 1, 2, 3, 7.
*         CALLS  WTC=.
  
  
 WTL      PS                 ENTRY/EXIT 
          SX7    B7 
          SA7    WTLA        SAVE B7
          PRINT  X1          PRINT LINE ON OUTPUT FILE
          SA1    TSEG 
          SA2    TSCR 
          SA3    WTLA 
          SB4    X2          RESTORE B REGISTERS
          SB5    X1 
          SB7    X3 
          EQ     WTL
  
 WTLA     CON    0           REGISTER SAVE AREA 
 SPD      SPACE  4,10 
**        SPD    SET PRINT DENSITY. 
* 
*              THIS ROUTINE ISSUES A CARRIAGE CONTROL LINE TO SET THE 
*         PRINT DENSITY FOR THE MAP.  IT ALSO FLAGS THAT MAP PRINTING HAS 
*         BEGUN.
*         USES   X - 1,2,6. 
*                A - 1,2,6. 
*                B - NONE.
* 
*         CALLS  WTO=.
  
 SPD      PS                 ENTRY/EXIT 
          SA1    PRDEN
          MI     X1,SPD1     IF NOT FIRST TIME
          BX6    -X1         FLAG MAP STARTED 
          SA6    A1 
          BX1    -X1
 SPD1     SA2    =0LT 
          R=     X1,X1+8
          ZR     X1,SPD2     IF PRINT DENSITY IS 8 LINES/INCH 
          SA2    =0LS 
 SPD2     BX6    X2 
          WRITEO O
          EQ     SPD         EXIT 
 RPD      SPACE  4,10 
**        RPD -RESET PRINT DENSITY. 
* 
*              ISSUES A CARRIAGE CONTROL LINE TO RESET THE PRINT
*         DENSITY TO INSTALLATION DEFAULT.
* 
*         USES   X - 1,2,6. 
*                A - 1,2,6. 
*                B - NONE.
* 
*         CALLS  WTO=.
  
 RPD      PS                 ENTRY/EXIT 
          SA1    PGPAR
          MX6    -4 
          AX1    12+8+8      POSITION FOR JOB *PD*
          SA2    PRDEN
          BX1    -X6*X1 
          BX6    X2 
          AX6    60          FORM SIGN
          BX2    X6-X2       GET ABSOLUTE *PD*
          IX6    X2-X1
          ZR     X6,RPD      IF NO NEED TO RESET *PD* 
          R=     X6,1RS-6/2  FORM BASE FOR *PD* 
          AX1    1           DIVIDE *PD* VALUE BY 2 
          IX6    X6+X1
          LX6    -6          *PD* TO SIGN BIT 
          WRITEO O
          EQ     RPD         EXIT 
          SPACE  4,8
          USE    // 
 ENDS     BSS    0                 END OF SEGMENTED LOAD OVERLAY
