*DECK     ALLOC 
          IDENT  ALLOC
 ALLOC    SECT   (TABLE ALLOCATION AND MANIPULATION.),1 
  
          SST    B,D
          NOREF  B,D
  
 B=ALLOC  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          ENTRY  ERT,NEXT,ALC.REG,ALC.00,ALC.CAI,SCSA,ALC.ASF,ADW,NCM 
          ENTRY  ALC,PRS,ESY,SCD,SSY,DSRT,MVE,SRT,NCS,ESN,SSN 
          ENTRY  ESC,NAP,SCS,ALC.DO,SCT,SCTR
          ENTRY  IDENT,ALC.PIG
  
*         IN FTN
          EXT    BINIOF,CO.SNAP,F.LF,F.OUT,F.RMAP,F.LGO 
          EXT    CO.SNAP,F.LF,F.OUT,F.RMAP,F.LGO
  
*         IN TABLES 
          EXT    BINIO,BASES,CDD,FAILSFT,IGS,LOSTREF
          EXT    N.TABLE,NREXT,ORIGINS,PASS,REFIO 
          EXT    REFLIN,SIZES,STAGE,TA=PRO,TG.APL,TA=NAM,TP=DIM 
          EXT    TP=DO,TP=FMT,TP=NLST,TP=APL,TP.APL,TS=CON,TS=EQU,TS=DAT
          EXT    TS=BLK,TS=ENT,TS.CON,TS.SYM,TT=LINK,TT=FILL,TT.LF,TT=LF
          EXT    TT=USE,TT=SCR,TT=PAR,TT=REF,TT.ASF,TT.PAR,TT.REF,T.VDIM
          EXT    TT=ASF,TP.DO 
  
*         IN ERRORS 
          EXT    E.MO2,E.MO4,E.MO5
  
*         IN PIG
          EXT    DPT
  
*         IN END
          EXT    DLF
  
*         IN MAIN 
          EXT    CPM=BY,WBL 
  
*         IN INIT 
          EXT    ADWT 
  
 ADW      SPACE  4,20 
**        ADW -  ADD ONE WORD TO END OF MANAGED TABLE.
* 
*         ENTRY  (X6) = DATUM.
*                (A1) _ ORIGIN WORD OF TABLE. 
* 
*         EXIT   (X1) = ORIGIN OF TABLE.
*                (X2) = NEW LENGTH OF TABLE 
*                (X3) = DATUM.
*                (X6) = DATUM.
*                (A1) _ ORIGIN WORD OF TABLE. 
*                (A2) _ LENGTH WORD OF TABLE. 
*                (A6) _ LWA OF TABLE, WHERE *DATUM* WAS JUST STORED.
*                (B7) = LWA + 1 OF TABLE
* 
*         THE MACRO CALL *ADDWD* SHOULD ALWAYS BE USED. 
*         USES   A2,A3,A6  X0,X6,X7  B2,B3,B7 
*         CALLS  ALC
  
          IFNE   TEST,,1
          ENTRY  ADW2 
  
 ADW1     SA6    ADWT        SAVE DATUM 
          RJ     ALC
 ADW2     SA3    ADWT 
          BX6    X3 
          =A6    B7-1 
  
 ADW      SUBR   0
          =X0    1
          EQ     ADW1 
  
 ALC      SPACE  4,40 
**        ALC -  TABLE MANAGER AND ALLOCATOR. 
* 
*         ALLOCATOR WILL MOVE TABLES TO ACQUIRE ROOM.  ALSO MAY DUMP
*         INTERMEDIATE OR CROSS-REFERENCES ONTO SCRATCH FILE. 
*         WILL ABANDON CMLOD IF NECESSARY, FORCING *T.LGO* TO DISK. 
* 
*         STOLEN FROM *COMPASS VER 2.0* 
* 
*         ENTRY  (A1) _ ORIGIN WORD OF TABLE. 
*                (X0) = CHANGE (+ OR -) TO TABLE SIZE.
* 
*         EXIT   (X1) = ORIGIN OF TABLE.
*                (X2) = NEW LENGTH OF TABLE.
*                (A1) _ ORIGIN WORD OF TABLE. 
*                (A2) _ LENGTH WORD OF TABLE. 
*                (B7) = LWA + 1 OF TABLE
* 
*         THE MACRO CALL *ALLOC* SHOULD ALWAYS BE USED. 
* 
*         NOTE SPECIAL DEAL FOR *ASF* EXPANSION --
*                WHEN A STATEMENT FUNCTION IS BEING EXPANDED, (B4) IS 
*                POINTING TO SOME TABLE, WHICH WE ARE ABOUT TO MOVE.
*                TO AVOID THE EMBARASSMENT WHICH MIGHT OTHERWISE OCCUR, 
*                THE MANAGER WILL RE-LOCATE A REGISTER RELATIVE TO A
*                DESIGNATED TABLE.  THIS IS INDICATED BY SETTING
*                (ALC.REG) =  24/ 0,  18/ REG,  18/ TABLE 
*                    (REG) = ADDRESS OF CELL WHERE DESIRED REGISTER IS
*                            SAVED BY *ALC*.
*                    (TAB) = ADDRESS OF TABLE ORIGIN WORD.
*                THIS CAN ONLY BE DONE FOR A REGISTER WHICH IS SAVED AND
*                RESTORED BY THE MANAGER. 
* 
*         USES   A1-A3,A6,A7  B7  X0-X3,X6,X7 
*         KEEPS  A0,A4,A5  B2-B6  X4,X5 
*         CALLS  ASU, ABORT, DLF, MESAGE, MTD, MVE, WRITEW
  
  
 ALCW     BSS    0
 SNAP=T   IFNE   TEST 
          SA1    CO.SNAP
          LX1    1RT
          PL     X1,ALCW1    IF TABLE SNAP NOT SELECTED 
          SA1    =10H ALCW
          RJ     =XPTA       PRINT TABLE ALLOCATION 
 ALCW1    BSS    0
 SNAP=T   ENDIF 
  
          SA2    ALC.REG
          =A1    A2+1        = OLD ORIGIN 
          SA3    X2          = NEW ORIGIN 
          AX2    18 
          IX6    X3-X1       = DISPLACEMENT 
          SA2    X2          = OLD REGISTER VALUE 
          IX6    X2+X6
          SA6    A2          STORE NEW REGISTER VALUE 
  
          SA1    B2+BASES    RECLAIM TABLE ORIGIN WORD
  
**        WE PROMISED TO PRESERVE MANY REGISTERS.  IT IS TIME TO RESTORE
*                THEM.
  
                             (ALCD) 
          SA5    ALCD        +0 = (B2)
          SB2    X5 
          =A4    A5+1        +1 = (B3)
          SB3    X4 
          =A3    A4+1        +2 = (B4)
          SB4    X3 
          =A2    A3+1        +3 = (B5)
          SB5    X2 
          =A5    A2+1        +4 = (B6)
          SB6    X5 
  
          =A4    A5+1        +5 = (A4)
          =A3    A4+1        +6 = (A5)
          =A2    A3+1        +7 = (X4)
          SA4    X4 
          SA5    X3 
          =A3    A2+1        +8 = (X5)
          BX4    X2 
          LX5    X3 
  
          SA2    A1+N.TABLE  RECLAIM TABLE LENGTH WORD
 ALCZ     IX6    X1+X2
          NO
          NO
          SB7    X6          (B7) = LWA + 1 OF TABLE
  
 ALC      SUBR   0
          SA2    A1+N.TABLE  CURRENT SIZE 
          =A3    A1+1        ORIGIN OF NEXT 
          IX2    X0+X2       NEW SIZE 
          =X6    X1+FUDGE 
          IX7    X3-X6
          IX7    X7-X2
  
**               TABLES HAVE CRASHED WHEN --
*         ORG(TABLE) + LENGTH(TABLE) + INCREMENT + 1 > ORG(NEXT)
  
          BX6    X2 
          SA6    A2          UPDATE SIZE
          PL     X7,ALCZ     IF NO CRASH, EXIT..
  
  
**        WE HAVE A CRASH AND MUST RE-ALLOCATE -- PREPARE TO DO SO. 
*                SAVE REGISTERS.
  
          IX6    X2-X0
          BX7    X5 
          SA6    A2          RESTORE ORIGINAL SIZE, TEMPORARILY 
          LX6    X4 
                             (ALCD) 
          SA7    ALCD+8      +8 = (X5)
          =A6    A7-1        +7 = (X4)
          SX7    A5 
          SX6    A4 
          =A7    A6-1        +6 = (A5)
          =A6    A7-1        +5 = (A4)
          SX7    B6-B0
          SX6    B5-B0
          =A7    A6-1        +4 = (B6)
          =A6    A7-1        +3 = (B5)
          SX7    B4-B0
          SX6    B3-B0
          =A7    A6-1        +2 = (B4)
          =A6    A7-1        +1 = (B3)
          SX7    B2-B0
          SB2    BASES
          SB2    A1-B2
          =A7    A6-1        +0 = (B2)
  
**        SAVE THE BASE ADDRESS OF THE TABLE DESIGNATED BY (ALC.REG) FOR
*                THE *RELATIVE-REGISTER* FEATURE. 
  
          SA2    ALC.REG
          SA1    X2          FETCH OLD BASE 
          BX6    X1 
          =A6    A2+1 
  
  
**        COMPUTE --
*                (L) = SPACE CURRENTLY OCCUPIED BY TABLES.
*                    = SIGMA (0.LT. I .LT. N,  L(I) ) 
*                (A) = ALLOCATABLE SPACE CURRENTLY UNNEEDED.
*                    = S - N*FUDGE - ( L + D )
  
 ALC.CK   SA2    =XW.TABS    SEE IF ENOUGH ROOM 
          SB7    N.TABLE-1
          SX3    X0+B7       ADD IN MINIMUM 1 WORD PER TABLE
 ALC22    SA1    SIZES+B7 
          SB7    B7-B1
          IX3    X3+X1
          PL     B7,ALC22    SUM SIZES OF ALL TABLES
          IX1    X2-X3
          SB4    X3          (B4) = TOTAL LENGTH
 .SNAP    IFNE   TEST 
          RJ     =XPTS       PRINT TABLE SIZES
 .SNAP    ENDIF 
          SA2    =XTHRESH 
          IX1    X1-X2       SUBTRACT THRESHHOLD AMOUNT 
          MI     X1,ALO      IF NOT ENOUGH ROOM FOR TABLE 
  
  
**        PACK ALL TABLES DOWN TO BOTTOM OF TABLE SPACE.
*                F(N) = (LOCORE) + (SIZCORE)
*                L(T) = L(T) + D
  
*                (B2) = T 
*                (B3) = I 
*                (B4) = L + D 
*                (B5) = A 
*                (B6) = D 
*                (X4) = F + S 
  
 ALC.GO   SB6    X0          (B6) = REQUESTED LENGTH
          SB5    X1          (B5) = SPACE AVAILABLE 
          RJ     MTD         MOVE TABLES DOWN TO LOW CORE 
          SA3    B2+SIZES    INCREMENT SIZE 
          SX6    X3+B6
          SA6    A3 
          SA1    =XF.TABS 
          SA2    =XW.TABS 
          IX4    X1+X2       X4 = LWA+1 OF CORE 
          SB3    N.TABLE-1
          ZR     B4,*+4S15   IF NO LENGTH 
  
  
**        RE-ALLOCATE AND MOVE TABLE (I) TO ITS NEW POSITION. 
*                --  N .GT. I .GT. 0   -- 
*                F(I) = F(I+1) - L(I) - D1 - D2 - FUDGE 
*                D1 = (1/2)*(A) / (N) 
*                D2 = (1/2)*(A) * (L(I)/L)
  
 ALC25    SB3    B3-B1       DECREMENT TABLE POINTER
          SA2    B3+BASES    TABLE ORIGIN 
          SX0    B5          SPACE AVAILABLE
          SA1    A2+N.TABLE 
          SX3    N.TABLE-1
          AX7    X0,B1
          IX6    X0/X3       = A / N
          SX3    B4          TOTAL LENGTH 
          IX7    X7*X1       = A/2 * L(I) 
          AX6    1
          IX7    X7/X3       = A/2 * (L(I)/(L+D)) 
          IX6    X6+X7
          =X6    X6+FUDGE    = AMOUNT OF SLOP ABOVE THIS TABLE
          IX6    X4-X6       = F(I+1) - (K + (A*L(I)/(L+D)/2) + (A/2/N) 
          UX1    X1 
          IX7    X6-X1       F(I) = (X6) - L(I) 
          BX3    X7 
          SA7    A2          SET NEW ORIGIN 
          LX4    X7 
          ZR     X1,ALC27    IF EMPTY TABLE 
          RJ     MVE
 ALC27    NE     B3,B1,ALC25 IF MORE TABLES TO ALLOCATE 
  
  
**        SET THE LOWEST TABLE TO THE BEGINNING OF TABLE SPACE, TO
*                RECLAIM THE SPACE LOST THRU TRUNCATION --
*                F(0) = F = (LOCORE)
  
          SA3    =XF.TABS 
          SA2    BASES       FETCH FWA
          SA1    SIZES       FETCH SIZE 
          LX6    X3 
          BX4    X3-X2
          SA6    A2 
          ZR     X4,ALCW     IF LOWEST TABLE NOT MOVED
          RJ     MVE
          EQ     ALCW        EXIT.. 
 ALO      SPACE  4,8
**        CORE OVERFLOW -- IT BECOMES NECESSARY (OR DESIRABLE) TO SPILL 
*         TO DISK OR ASK FOR MORE CORE.  IF FIELD LENGTH IS GREATER 
*         THAN NOMINAL FIELD LENGTH WE WILL SPILL TO DISK.  IF NOT
*         OR IF WE ALREADY SPILLED WE GET MORE CORE.
  
  
 ALO      SX6    B2          SAVE ENTRY CALL VALUES 
          BX7    X0 
          SA6    ALCC 
          =A7    A6+1 
          BX6    X1 
          =A6    A7+1        SAVE (AMOUNT OF CORE REQUIRED) 
  
*         IF WE ARE IN END PROCESSING (ASSEMBLY PHASE) TRY DUMPING
*         THE LINK AND FILL TABLES. 
  
          SA1    PASS 
          SA2    TT=LINK
          =B2    X1-PASS=END
          SA3    TT=FILL
          NZ     B2,ALC40    IF NOT IN PASS 3 
          SA1    NREXT
          IX0    X2+X3
          IX7    X0-X1
          SA3    =XTT=XFIL
          IX7    X7+X3
          SB7    X7-2 
          LE     B7,ALC40    IF NO ROOM TO BUY
          RJ     DLF         DUMP LINK AND FILL 
          EQ     ALO.OK      TRY AGAIN..
  
  
**        NO HELP ON LINK/FILL.  TRY TO OVERFLOW INTERMEDIATE.
*                IF IN MAP PROCESSING, WE ARE AT THE END OF OUR ROPE. 
  
 ALC40    =B7    PASS=END-PASS=MAP
          SA3    =XCP.AFLS   TOTAL FIELD LENGTH 
          SX6    INC.LTN     FIELD LENGTH INCREMENT WHEN FL .LT. NOMINAL
          EQ     B7,B2,ALC.GM      GET MORE MEMORY IF IN REF MAP PASS 
          SA1    =XBINIO
          SX4    =XNOM.TFL
          MI     X1,ALC50    IF BINARY ALREADY ON DISK
          IX2    X4-X3       NOMINAL - ACTUAL FIELD LENGTH
          PL     X2,ALC.GM   IF FL .LT. NOMINAL GET MORE CORE 
          SA1    IGS
          SA2    ALCC+2      (X2) = -(AMOUNT NEEDED)
          IX1    X1+X2
          MI     X1,ALC50    IF NO ROOM TO BUY
          MX6    -1 
          SA6    BINIO       INDICATE TT.LF ON DISK 
          OPEN   F.LF,,RCL
          SA3    IGS
          SA1    TT.LF
          WRITEW F.LF,X1,X3 
 .TEST    IFNE   TEST,0,1 
          NOTE   E.MO4       ** INTERMEDIATE GOES TO DISK **
          SA3    PASS 
          SA1    IGS
          =B2    X3-PASS=END
          SA3    TT=LF
          ZR     B2,ALC45    IF IN *END*
          SA2    TT.LF
          BX6    0
          IX7    X2+X1       FWA = FWA + IGS
          SA6    A1 
          IX6    X3-X1       LEN = LEN - IGS
          SA7    A2 
          SA6    A3 
          EQ     ALO.OK      TRY AGAIN..
  
 ALC45    SHRINK A3 
          WRITER F.LF 
          REWIND F.LF 
  
          IFNE   CP#RM,7,1
          READ   F.LF 
  
          EQ     ALO.OK      TRY AGAIN..
  
  
**        INTERMEDIATE NO HELP -- TRY TO DUMP REFERENCES. 
  
 ALC50    SA1    REFIO
          SX6    INC.GTN     FIELD LENGTH INCREMENT WHEN FL .GT. NOMINAL
          MI     X1,ALC.GM   IF REFS ALREADY OUT GET MORE CORE
          SX6    INC.LTN     FIELD LENGTH INCREMENT WHEN FL .LT. NOMINAL
          IX2    X4-X3       NOMINAL - ACTUAL FIELD LENGTH
          PL     X2,ALC.GM   IF FL .LE. NOMINAL GET MORE CORE 
          SX6    INC.GTN     FIELD LENGTH INCREMENT WHEN FL .GT. NOMINAL
          SA2    TT=REF 
          SA1    ALCC+2      (X1) = - (AMOUNT NEEDED) 
          IX2    X2+X1
          MI     X2,ALC.GM   IF NO ROOM TO BUY
          MX7    -1 
          SA7    REFIO       INDICATE TT.REF ON DISK
          OPEN   F.RMAP,,RCL
          SA3    TT=REF 
          SA1    TT.REF 
          SHRINK A3 
          WRITEW F.RMAP,X1,X3 
 .TEST    IFNE   TEST,0,1 
          NOTE   E.MO5       ** CROSS REFERENCE GOES TO DISK ** 
*         EQ     ALO.OK      TRY AGAIN..
  
**        SOMETHING WAS SUCCESSFULLY DUMPED --
*                RETRIEVE ENTRY VALUES AND TRY AGAIN. 
  
 ALO.OK   SB7    ALC.CK 
          SA1    ALCC+2 
  
 ALO.OK2  =A3    A1-1        RESTORE ENTRY VALUES 
          =A2    A3-1 
          BX0    X3 
          SB2    X2 
          JP     B7          TRY AGAIN..
  
  
**        GET MORE MEMORY 
*         ENTRY  (X6) = INCREMENT 
*                (X3) = CP.AFLS 
  
 ALC.GM   SA1    =XMAX.FL    MAX FL FOR JOB STEP
          IX6    X3+X6       CURRENT FL + INCREMENT 
          IX4    X1-X6       MAXFL - NEWFL
          PL     X4,ALC.GM1  IF NEWFL .LE. MAXFL
          IX2    X3-X1       CURRENT FL - MAXFL 
          PL     X2,ALC.OV   IF MAXFL .LE. CURRENT FL, DIE
          BX6    X1          NEWFL = MAXFL
 ALC.GM1  LX6    30 
          SA6    =XGT1
          MEMORY SCM,GT1,RCL
          SA1    =XGT1
          AX1    30 
          BX6    X1 
          SA6    =XCP.AFLS   SET ACTUAL FL
          SX6    X6-10
          SA6    =XCP.NFLS   SET NOMINAL FL 
          SA6    =XT.END
          SA1    =XF.TABS    BEGINNING OF TABLES
          IX6    X6-X1
          SA6    =XW.TABS    AMOUNT OF CORE TO BE MANAGED 
          AX6    FLSLOP 
          SA6    =XTHRESH    GIVE ALLOC SOME ELBOW ROOM 
          EQ     ALO.OK      TRY AGAIN
  
  
**        IT WAS ALL TO NO AVAIL.  REPORT FAILURE AND ABORT.
*         ENTRY  (X6) = PASS NUMBER 
  
 ALC.OV   SA1    ALCC+2 
          SB7    ALC.GO 
          PL     X1,ALO.OK2  IF THRESHOLD ALARM 
          SA2    FAILSFT
          NZ     X2,ALO.DIE  IF ALREADY HAD OVERFLOW
          BX6    0
          =X7    X2+1 
          SHRINK TT=ASF,X6
          SA7    A2          SET FAILSOFT FLAG
          SHRINK TP=DIM,X6
 .CMLOD   IFNE   .CMLOD,,1
          SHRINK T=LGO,X6 
          SHRINK TT=LF,X6 
          SHRINK TT=USE,X6
          SHRINK TT=SCR,X6
          SHRINK TS=CON,X6
          SHRINK TA=NAM,X6
          SHRINK TP=DO,X6 
          SHRINK TS=EQU,X6
          SHRINK TP=FMT,X6
          SHRINK TT=PAR,X6
          SHRINK TP=NLST,X6 
          SHRINK TP=APL,X6
          SHRINK TA=PRO,X6
          SHRINK TS=DAT,X6
          SHRINK TT=REF,X6
          =X7    CPM=BY 
          SHRINK TS=BLK,X6
          SHRINK TS=ENT,X6
          SA7    STAGE       BYPASS REST OF PROGRAM 
          FATAL  E.MO2
          SA1    PASS 
          SX1    X1-PASS=END
          MI     X1,=XPSP.F  IF NOT IN END OR MAP PROCESSING
          EQ     =XEND96     FINISH OFF THIS COMPILATION
  
  
**        NOT EVEN ENUF ROOM TO SKIP TO AN *END* CARD --
*                DAYFILE MESSAGE AND ABORT JOB
  
 ALO.DIE  PLINE  ALC=OV,3,2 
          MESAGE ALC=OV,,RCL
          WRITER F.OUT
          WRITER F.LGO
          EQ     =XENDFTN 
  
 ALCC     DATA   0,0         TEMPORARY STORAGE FOR OVERFLOW 
          CON    0           SAVE CORE REQUIRED 
  
                             SAVE CELLS DURING TABLE MOVES -- 
 ALCD     BSS    1           (B2) 
          BSS    1           (B3) 
 ALC=B4   BSS    1           (B4) 
 ALC=B5   BSS    1           (B5) 
          BSS    1           (B6) 
          BSS    1           (A4) 
 ALC=A5   BSS    1           (A5) 
          BSS    1           (X4) 
          BSS    1           (X5) 
  
 ALC=00   EQU    ALCD-1      FAKE, USED TO NO-OP RELATIVE REGISTER
  
 ALC.REG  VFD    24/0,18/ALC=00,18/BASES
          BSS    1           SAVE CELL FOR ORIGIN OF RELATIVE TABLE 
  
 ALC.00   VFD    24/0,18/ALC=00,18/BASES
 ALC.ASF  VFD    24/0,18/ALC=B4,18/TT.ASF 
 ALC.CAI  VFD    24/0,18/ALC=B4,18/TT.PAR 
 ALC.FVD  VFD    24/0,18/ALC=B4,18/T.VDIM 
 ALC.DO   VFD    24/0,18/ALC=B5,18/TP.DO
 ALC.PIG  VFD    24/0,18/ALC=A5,18/TT.LF
  
 ALC=OV   DIS    2, TABLE OVERFLOW IN 
 IDENT    DATA   0           ROUTINE NAME 0L FORMAT 
          CON    0           ZERO WORD STOPPER FOR PVF
 ALE      SPACE  4,15 
 ERT      SPACE  4,8
**        ERT -  ENTER REFERENCE TABLE. 
*         ENTRY  (X6) = TAG.
*                (X1) = USAGE LETTER CR.XXX AS DEFINED IN TSTEXT. 
* 
*         NOTE
*                ALL CALLS TO *ERT* SHOULD USE MACRO *ADDREF* 
* 
*         USES   A1-A4,A6,A7  B2,B3,B7  X0-X3,X6,X7 
*                PRESERVES  A0,A5  X4,X5  B4,B5,B6
*                (ADWT+0 - +1)
*                (ALCD+0 - +2)
  
  
 ERT1     SHRINK TT=REF,0    TABLE JUST OVERFLOWED
  
 ERT2     SX6    B6 
          SX7    B5 
          SA6    ERTD        (ERTD+0) = (B6)
          =A7    A6+1             +1  = (B5)
          BX6    X4 
          =A6    A7+1             +2  = (X4)
          SX0    B4          SAVE (B4)
          WRITEW F.RMAP,ADWT,1
          SB4    X0          RESTORE (B4) 
          SA2    ERTD 
          SA1    ADWT+1 
          =A3    A2+1 
          =A4    A3+1        RESTORE (X4) 
          SB6    X2          RESTORE (B6) 
          SB5    X3          RESTORE (B5) 
          SB7    X1 
          JP     B7          EXIT.. 
  
 ERT      SA2    REFLIN      THIS INSTRUCTION IS CHANGED BY CONTROL CARD
,                            PROCESSING IF X-REF IS NOT SELECTED. 
          MX0    L.TAG
          BX6    X0*X6       ISOLATE TAG
          IX3    X1+X2       PAGE, LINE, USE
          SA1    LOSTREF
          IX6    X3+X6
          SA6    ADWT 
          SX6    X1+B1       ACCUMULATE REF COUNT 
          SA2    REFIO
          SA6    A1 
          SX6    B7 
          SA6    ADWT+1      SAVE EXIT ADDRESS
          NZ     X2,ERT2     IF ON DISK 
  
          ALLOC  TT.REF,1 
          SA3    REFIO
          NZ     X3,ERT1     IF JUST OVERFLOWED 
          SA3    ADWT+1 
          =A2    A3-1 
          SB2    X3 
          BX6    X2 
          =A6    B7-1        STORE REFERENCE IN TABLE 
          JP     B2          EXIT.. 
  
 ERTD     EQU    ALCD        SAVES (B6, B5, X4) 
 ESC      SPACE  4,8
**        ESC -  EXPAND SHORT CONSTANT
* 
*         ENTRY  (X5) = PROPOSED SHORT CONSTANT 
* 
*         EXIT   IF (X5) WAS NOT A SHORT CONSTANT 
*                   (X5) = PRESERVED. 
*                IF (X5) WAS SHORT. 
*                   (X5) = CONSTANT TAG.
*         USES   A1,A2,A3,A6,A7  X0  B2,B7
*                (ADWT+1) 
  
  
 ESC      SUBR   0
          BX2    X5 
          MX0    -L.MODE
          IFBIT  X2,-SHORT,ESCX    IF NOT SHORT CONSTANT
          BX7    -X0*X5 
  
**        CHECK FOR MASK-TYPE CONSTANT
  
          MX0    -L.MSHORT
          LX0    P.MSHORT 
          BX2    -X0*X5 
          ZR     X2,ESC3     IF NOT MASK-TYPE CONSTANT
          AX2    P.MSHORT 
  
*         CREATE LONG CONSTANT
  
          MX5    1
          SB2    X2-1 
          AX5    B2,X5
          EQ     ESC5 
  
 ESC3     SB7    X7-M.REAL
          AX5    P.SHC
          NZ     B7,ESC5     IF NOT REAL
          LX5    P.SHC
 ESC5     BX6    X5 
          SCAN   TS.CON,SCT 
          MI     B7,ESC10    IF NOT IN TABLE
          SX0    B7+C.CON 
          LX0    P.2TAG 
          IX5    X0+X7       MERGE MODE 
          EQ     ESCX        EXIT.. 
  
**        IF NOT IN CONSTANT TABLE
  
 ESC10    SA7    ADWT+1      SAVE MODE
          ADDWD  A1 
          SX0    X2+C.CON-1 
          SA2    ADWT+1      MODE 
          LX0    P.2TAG 
          BX5    X0+X2       MERGE MODE 
          EQ     ESCX        EXIT.. 
 ESN      SPACE  4,8
**        ESN -  ENTER *STATEMENT NUMBER*/*TAG* IN TABLE. 
* 
*         ENTRY  (A1) _ TABLE TO BE ENTERED.
*         ENTRY  (X6) = SYMBOL. 
*                (X7) = TAG ENTRY.   18/0, 42/AS DESIRED. 
*                TAG ENTRY MUST NEVER HAVE ANYTHING SET IN THE HIGH 
*                ORDER L.TAG BITS.
*                (NEXT) = ORDINAL. (SEE *SHT*)
*         EXIT   (X0) = ORDINAL OF *SYMBOL* ENTRY.
*                (A6) _ TAG JUST ENTERED. 
*                (X6) = TAG.
*                (A6)-1 _ STATEMENT NUMBER JUST ENTERED.
*                (B7) = ORDINAL OF SYMBOL ENTRY.
* 
*         USES   A1,A2,A3  X0  B2,B7
*         CALLS  MANAGE 
  
  
**        HERE IF BASE ENTRY CLEAR. 
  
 ESN10    BX0    -X2
          SB7    X0 
          SX3    X0+C.STAT+1 ORDINAL+ TAG BITS. 
          SA6    X1+B7
          LX3    P.TAG
          IX6    X3+X7
          SA6    A6+B1       STORE *TAG*
  
 ESN      SUBR   0
          SA2    NEXT 
          MI     X2,ESN10    IF *BASE INDEX* NOT OCCUPIED.
  
**        HERE IF BASE ENTRY OCCUPIED.
  
 ESN5     SA6    SSYM 
          BX6    X7 
          SA6    A6+B1       SAVE SYMBOL + TAG. 
          ALLOC  A1,2 
  
**        HERE WITH 
*         (X1) = NEW ORIGIN 
*         (X2) = LENGTH.
*         (NEXT) = ORDINAL OF SYMBOL ENTRY THAT NEEDS LINK FIELD. 
  
          SB2    X1 
          SA1    NEXT 
          SX0    X2-2        ORDINAL
          SA2    X1+B2       CHAIN ENTRY TO BE MODIFIED 
          SA1    SSYM        SYMBOL 
          IX6    X2+X0       ADD CHAIN LINK TO SYMBOL.
          SA3    A1+B1       TAG
          SA6    A2 
          LX6    X1 
          SX2    X0+C.STAT+1
          SA6    X0+B2       NEW SYMBOL ENTRY 
          LX2    P.TAG
          IX6    X2+X3
          SA6    A6+B1       NEW TAG    ENTRY 
          SB7    X0          ORDINAL OF SYMBOL ENTRY. 
          EQ     ESNX        EXIT.. 
 ESY      SPACE  4,8
**        ESY -  ENTER *SYMBOL*/*TAG* IN TABLE. 
* 
*         ENTRY  (A1) _ TABLE TO BE ENTERED.
*         ENTRY  (X6) = SYMBOL. 
*                (X7) = TAG ENTRY.   18/0, 42/AS DESIRED. 
*                TAG ENTRY MUST NEVER HAVE ANYTHING SET IN THE HIGH 
*                ORDER L.TAG BITS.
*                (NEXT) = ORDINAL. (SEE *SHT*)
*         EXIT   (X0) = ORDINAL OF *SYMBOL* ENTRY.
*                (A6) _ TAG JUST ENTERED. 
*                (X6) = TAG.
*                (A6)-1 _ SYMBOL JUST ENTERED.
*         (B7) _ ORDINAL OF *SYMBOL* ENTRY. 
*         USES   A1,A2,A3  X0  B2,B7
*         CALLS  MANAGE.
  
  
**        HERE IF BASE ENTRY CLEAR. 
  
 ESY10    BX0    -X2
          SB7    X0 
          SX3    X0+C.SYM+1  ORDINAL+ TAG BITS. 
          SA6    X1+B7       STORE *SYMBOL* 
          LX3    P.TAG
          IX6    X3+X7
          SA6    A6+B1       STORE *TAG*
  
 ESY      SUBR   0
          SA2    NEXT 
          MI     X2,ESY10    IF *BASE INDEX* NOT OCCUPIED.
  
**        HERE IF BASE ENTRY OCCUPIED.
  
 ESY5     SA6    SSYM 
          BX6    X7 
          SA6    A6+B1       SAVE SYMBOL + TAG. 
          ALLOC  A1,2 
  
**        HERE WITH 
*         (X1) = NEW ORIGIN.
*         (X2) = LENGTH.
*         (NEXT) = ORDINAL OF SYMBOL ENTRY THAT NEEDS LINK FIELD. 
  
          SB2    X1 
          SA1    NEXT 
          SX0    X2-2        ORDINAL
          SA2    X1+B2       CHAIN ENTRY TO BE MODIFIED 
          SA1    SSYM        SYMBOL 
          IX6    X2+X0       ADD CHAIN LINK TO SYMBOL.
          SA3    A1+B1       TAG
          SA6    A2 
          LX6    X1 
          SX2    X0+C.SYM+1 
          SA6    X0+B2       NEW SYMBOL ENTRY 
          LX2    P.TAG
          IX6    X2+X3
          SA6    A6+B1       NEW TAG    ENTRY 
          SB7    X0          ORDINAL OF SYMBOL ENTRY. 
          EQ     ESYX        EXIT.. 
  
 SSYM     DATA   0,0         SYMBOL,TAG ENTRYS. 
 FUC      SPACE  4,20 
 MTD      SPACE  4,8
**        MTD -  MOVE ALL TABLES TO LOW CORE. 
*         PACKS UP ALL TABLES AT LOWER END OF MANAGED SPACE.
*         USES   A1,A2,A6,A7  X0,X3,X4  B3,B7 
*         CALLS  MVE
  
  
 MTD      SUBR   0
          SB3    N.TABLE-1
          SB3    -B3
          SA2    =XF.TABS 
          BX4    X2 
  
 MTD1     SX1    B3+N.TABLE-1 
          SA2    X1+ORIGINS 
          SA1    X1+SIZES 
          LX3    X4 
          IX4    X4+X1
          LX7    X3 
          SA7    A2 
          SB3    B3+B1
          RJ     MVE
 MTD2     NZ     B3,MTD1     IF MORE TABLES TO DO 
          EQ     MTDX        EXIT.. 
 MTU      SPACE  4
**        MTU - MOVE ALL TABLES TO HIGH CORE. 
  
 MTU      SKIP
  
 MTU      PS                 RETURN EXIT
          SB2    NTABLES
          SA1    =XF.TABS 
          SA2    =XW.TABS 
          IX0    X1+X2       LWA+1 OF TABLE SPACE AVAILABLE 
          SB3    B2-B1
 MTU1     SB3    B3-B1
          SA2    ORIGINS+B3 
          SA1    SIZES+B3 
          IX7    X0-X1
          LX0    X7 
          SA7    A2 
          BX3    X0 
          RJ     MOVE 
          NZ     B3,MTU1     LOOP 
          EQ     MTU         EXIT 
 MTU      ENDIF 
 MVE      SPACE  4,15 
**        MVE - MOVE BLOCK OF DATA. 
* 
*         G. R. MANSFIELD.  70/09/04. 
*         ADAPTED FROM SUBROUTINE *MOVE* IN *COMPASS VER 2.0*.
*         THIS VERSION ADAPTED TO COMPILER FROM ABOVE.
* 
*         MVE MOVES A BLOCK OF DATA UPWARDS OR DOWNWARDS, TO AVOID OVER-
*                STORES.  WILL NOT MOVE ANYTHING IF WORD COUNT IS ZERO, 
*                OR SOURCE = DESTINATION. 
* 
*         ENTRY  (X1) = WORD COUNT. 
*                (X2) = SOURCE ADDRESS. 
*                (X3) = DESTINATION ADDRESS.
* 
*         USES   A1,A2,A6,A7  X0,X3  B7 
  
  
*         BEGIN DOWNWARD MOVE 
  
 MVE2     SB7    -2          UPWARD MOVE
          SX2    X2+B7
          SX3    X3+B7
          SB7    B1+B1
          ZR     X6,MVE3     IF WORD COUNT EVEN 
          SA1    X2+B7       MOVE INITIAL WORD
          IX2    X2+X6
          BX7    X1 
          SA7    X3+B7
          IX3    X3+X6
  
*         INITIALIZE MOVE LOOP. 
  
 MVE3     ZR     X0,MVEX     IF MOVE COMPLETE 
          SA2    X2+B7       MOVE FIRST 2 WORDS 
          SA1    A2+B1
          BX6    X2 
          LX7    X1 
          SA6    X3+B7
          SA7    A6+B1
          SX3    B1+B1
          IX0    X0-X3
          ZR     X0,MVEX     IF MOVE COMPLETE 
          SA2    A2+B7       NEXT 2 WORDS 
          SA1    A1+B7
  
*         MOVE LOOP.
  
 MVE4     BX6    X2 
          SA2    A2+B7
          LX7    X1 
          SA1    A1+B7
          IX0    X0-X3
          NO
          SA6    A6+B7
          SA7    A7+B7
          NZ     X0,MVE4
  
 MVE      SUBR   0
          MX0    -1 
          IX7    X3-X2
          BX6    -X0*X1 
          IX0    X1-X6       REDUCE WORD COUNT TO EVEN NUMBER 
          ZR     X7,MVEX     IF NULL MOVE, AVOID..
          MI     X7,MVE2     IF MOVE DOWNWARD  (DESTINATION < SOURCE) 
  
*         BEGIN UPWARD MOVE 
  
          ZR     X6,MVE1     IF WORD COUNT EVEN 
          SB7    X0 
          SA1    X2+B7       MOVE INITIAL WORD
          BX6    X1 
          SA6    X3+B7
 MVE1     IX2    X2+X0
          IX3    X3+X0
          SB7    -2 
          EQ     MVE3 
  
  
 NAP      SPACE  4,8
**        NAP -  ENTER AP-LIST IN TABLE.
*         ENTRY  (B3) = LENGTH OF AP-LIST (INCLUDING THE ZERO WORD, IF
*                            ANY).
*                THE AP-LIST TO BE ENTERED IS THE LAST (B3) WORDS OF
*                            TP.APL.
*         EXIT   (X6) = AP-TAG OF THE INDICATED LIST. 
*                (TG.APL) IS UPDATED, AND ADDRESS OF TAG DEFINED. 
*         USES   A1,A2,A3,A6  B2,B3,B7  X0
  
  
 NAP      SUBR   0
          SA1    TP.APL 
          SA2    TP=APL 
          SB7    -B3
          IX0    X1+X2       LWA+1 OF LIST
          SB2    X0+B7       FWA LIST = LWA+1 - LEN 
          SB3    X0 
          SX6    X2+B7       FAKE LENGTH FOR *NCM* PROCESSING.
          SA6    A2          RESET LENGTH FOR *NCM* 
          RJ     NCM         SEARCH AP-TABLE FOR DUPLICATE LIST 
 NAP.NCM  BSS    0           ADDRESS OF RETURN FROM NCM 
          MX2    1
          SA3    TG.APL 
          IX0    X2+X6       ORDINAL + FLAG 
          =X6    X3+1 
          SA6    A3          UPDATE AP-TAG
          LX6    P.TAG
          BX6    X6+X0
          RJ     DPT         DEFINE PROGRAM TAG 
          MX0    L.TAG-1
          LX0    -1 
          BX6    X0*X6       STRIP OFF GARBAGE
          EQ     NAPX        EXIT...
 NCM      SPACE  4,30 
**        NCM -  ENTER *MULTI-WORD* ELEMENTS INTO REQUESTED TABLE.
* 
*         ENTRY  (A1) _ TABLE TO BE ENTERED.
*                (B2) _ FWA CONSTANTS.
*                (B3) _ LWA+1 ELEMENTS TO BE ENTERED. 
*                (X1) = ((A1))
* 
*         NOTE   LIKE MOST SCAN ROUTINES *NCM* REQUIRES A USABLE WORD 
*                PRECEDING CURRENT TABLE ABOUT TO SCAN. 
* 
*         NOTE   SPECIAL DEAL WHEN CALLED BY *NAP* -- 
*                            (EFFECTIVE WHEN RETURN ADDRESS = *NAP.NCM*)
*                IN THIS CASE, THE ELEMENTS ARE ACTUALLY ALREADY IN THE 
*                TABLE, AT THE VERY END.  TABLE LENGTH IS REDUCED BEFORE
*                *NCM* IS CALLED, TO HIDE THEM FROM OUR SEARCH LOOP.  IF
*                ENTITY IS NOT DUPLICATED IN THE TABLE, WE MERELY RESET 
*                THE LENGTH AND EXIT. 
* 
*         EXIT   ELEMENTS ENTERED 
*                (B7) = ORDINAL IN TABLE OF FWA CONSTANTS.
*                (X6) = (B7)
* 
*         CALLS  MANAGE, MVE
* 
*         USES   CANNOT DESTORY A4,A5,A7  B4,B5,B6
*                ADWT (+0 - +2) 
  
  
 NCM      SUBR   0
          SX6    B3 
          SX0    B3-B2
          SA6    ADWT        SAVE  B3 
          EQ     B2,B3,NCMX  IF NO WORDS TO ADD 
  
**        SCAN TABLE N TIMES TO CHECK IF ENTITY IS ALREADY IN TABLE.
  
          SA2    B2          1ST ELEMENT TO BE CHECKED. 
          SB7    X0-1        LENGTH OF THIS ENTRY 
          SA3    A1+N.TABLE  LENGTH OF TABLE. 
 NCM5     BX6    X2 
          SB3    X3 
          SA6    X1-1        DUMMY FIND 
          SA3    A6+B3
          LE     B3,B7,NCM50 IF TABLE TOO SMALL TO ALREADY HAVE IT
          SA3    A3-B7
          SB3    B3-B7
  
**        CHECK FOR 1ST ELEMENT 60 BIT MATCH. 
*         BACKWARD SCAN THRU TABLE. 
  
 NCM10    =B3    B3-1 
          BX6    X3-X2
          =A3    A3-1 
          NZ     X6,NCM10    IF NO MATCH
          MI     X6,NCM10    IF NO MATCH (-0 PROBLEM) 
          MI     B3,NCM50    IF DUMMY HIT - DEFINITELY NOT IN TABLE.
          =X6    A3+1 
          SA6    ADWT+1 
          =A2    A2+1 
          SA3    A3+2 
  
**        SCAN TABLE FOR REMAINING NTH ELEMENTS TO MATCH
  
 NCM20    ZR     B7,NCM30    IF ENTIRE LIST MATCHES 
          BX6    X2-X3
          =B7    B7-1 
          =A2    A2+1 
          =A3    A3+1 
          MI     X6,NCM22    IF NO MATCH (-0 PROBLEM) 
          ZR     X6,NCM20    IF CONTINUED MATCH 
  
**        HERE IF ONLY PARTIAL MATCH. 
*         RESET PARAMETERS AND START OVER.
  
 NCM22    SA3    ADWT+1 
          SA2    B2 
          SB7    X0-1 
          IX3    X3-X1       ORDINAL FOR RE-START.
          EQ     NCM5        TRY AGAIN .... 
  
**        HERE IF ENTITY IS ALREADY IN TABLE
*         SET-UP EXIT CONDITIONS AND EXIT.
  
 NCM30    SB3    X1 
          SX2    A3-B3
          IX6    X2-X0       ORDINAL
          SB7    X6 
          EQ     NCMX        EXIT.. 
  
**        HERE IF ENTITY NOT IN TABLE 
*         ALLOCATE ROOM FOR TABLE.
*         CHECK FOR SPECIAL *NAP* DEAL. 
  
 NCM50    SA3    NCM
          LX3    30 
          SB7    X3-NAP.NCM 
          NZ     B7,NCM55    IF NOT CALLED BY *NAP* 
          SA2    A1+N.TABLE 
          IX6    X2+X0
          SA6    A2          UPDATE LENGTH. 
          SB7    X2 
          SX6    X2 
          EQ     NCMX        EXIT.. 
  
 NCM55    SX6    B2 
          SA6    ADWT+1      SAVE *B2* (FWA)
          ALLOC  A1,X0       ALLOCATE ROOM IN TABLE.
  
**        MANAGE RETURNS WITH (X1) = NEW ORIGIN.
*                             (X2) = NEW LENGTH.
  
          BX0    X1 
          SA3    ADWT 
          =A1    A3+1 
          IX7    X2-X3
          SB3    X3          RESTORE B3 
          SB2    X1          RESTORE B2 
          BX2    X1          SOURCE.= (B2)
          SX6    X7+B2       ORDINAL = NEW LENGTH - WORD COUNT
          SA1    A7 
          IX3    X6+X0       DESTINATION = ORDINAL + ORIGIN 
          SA6    A3          SAVE ORDINAL 
          BX6    X1 
          SX1    B3-B2       WORD COUNT 
          SA6    ADWT+2      SAVE *(A7)*
          SX6    A7 
          =A6    A6+1        SAVE *A7*
  
**        MOVE ELEMENTS INTO TABLE. 
*                (X1) = WORD COUNT. 
*                (X2) = SOURCE ADDRESS
*                (X3) = DESTINATION ADDRESS.
  
          RJ     MVE
          SA1    ADWT+2 
          =A2    A1+1 
          BX7    X1 
          SA7    X2          RESTORE *A7* 
          SA1    ADWT 
          BX6    X1 
          SB7    X1 
          EQ     NCMX        EXIT.. 
 NCS      SPACE  4,20 
**        NCS -  SCAN / ENTER SINGLE WORD CONSTANT INTO CONSTANT TABLE. 
* 
*             NCS WILL FIRST CHECK IF CONSTANT CAN BE SET TO SHORT FORM,
*         BY CHECKING IF IT IS ONE OF BELOW TYPES 
*                A. UNIVERSAL 
*                B. INTEGER.
*          OR    C. REAL
* 
*         IF NOT, IT THEN SCANS CONSTANT TABLE TO CHECK IF CONSTANT IS
*         ALREADY IN TABLE. IF SO, IT SETS CURRENT TAG OFF OF RETURNED
*         ORDINAL, ADDS IN REQUESTED MODE BITS, AND EXITS.
* 
*         ENTRY  (X6) = CONSTANT VALUE TO BE ENTERED. 
*                (X7) = MODE OF CONSTANT. 
* 
*         EXIT   X6 = 18/K-TAG,24/0,18/MODE.
* 
*         USES   A1,A2,A3  X0,X6,X7  B2,B3,B7 
* 
*         CALLS  ADDWD, SCT 
  
  
**        HERE IF NOT POSSIBLE SHORT, ENTER INTO CONSTANT TABLE.
  
 NCS30    SA7    NCS.MOD     SAVE MODE
          SCAN   TS.CON,SCT  SCAN CON TABLE 
          MI     B7,NCS40    IF *NIT* 
          SX0    B7+C.CON 
          LX0    P.TAG
          BX6    X0+X7       MERGE MODE 
          EQ     NCSX        EXIT.. 
  
**        ADD NEW CONSTANT TO TABLE 
  
 NCS40    ADDWD  A1          ENTER INTO TABLE 
          SX0    X2+C.CON-1 
          SA2    NCS.MOD
          LX0    P.TAG
          IX6    X0+X2       MERGE MODE 
  
  
 NCS      SUBR   0
          SB2    X7-M.INT 
          EQ1    B2,NCS20    IF *REAL*
          PL     X6,NCS7     IF NOT NEGATIVE CONSTANT 
          ZR     B2,NCS6     IF *INTEGER* 
          NZ     X7,NCS20    IF NOT *CHAMELEON* 
 NCS6     =X0    1
          BX2    -X6
          IX3    X0+X2
          BX1    X3*X2
          NZ     X1,NCS7     IF NOT *MASK* TYPE CONSTANT
          BX0    -X2
          CX6    X0 
          LX6    P.MSHORT 
          EQ     NCS15       CONTINUE 
  
 NCS7     BX2    X6 
          AX2    L.SHC-1
          NZ     X2,NCS30    IF UPPER BITS NOT ALL SAME 
  
*         AVOID SETTING UP SHORT CONSTANT THAT LOOKS LIKE STATEMENT 
*         NUMBER TAG
  
          SX2    C.STN
          MX0    L.TGB
          LX0    L.TAG
          BX0    X0*X6
          IX0    X2-X0
          ZR     X0,NCS30    IF CONFUSION WITH STATEMENT NUMBER TAG 
          MX0    -L.SHC 
          BX6    -X0*X6 
          LX6    P.SHC
  
**        HERE IF SHORT CONSTANT. 
  
 NCS15    =X1    M.SHORT
          BX2    X6+X7       MERGE MODE 
          IX6    X2+X1
          EQ     NCSX        EXIT.. 
  
**        CHECK IF MODE = REAL, IF NOT ENTER CONSTANT.
  
 NCS20    SB2    X7-M.REAL
          BX2    X6 
          NZ     B2,NCS30    IF NOT REAL. 
          LX2    L.SHC
          AX2    L.SHC
          NZ     X2,NCS30    IF LOWER 42 BITS ARE NOT SAME AS SIGN
  
*                            THE SIGN BITS OF X2 + X6 MUST BE EQUAL 
  
          BX2    X2-X6
          NG     X2,NCS30    IF SIGN BIT IS DIFFERENT 
  
*         AVOID SETTING UP SHORT CONSTANT THAT LOOKS LIKE STATEMENT 
*         NUMBER TAG
  
          SX2    C.STN
          MX0    L.TGB
          LX2    P.TAG
          BX0    X0*X6
          IX0    X2-X0
          ZR     X0,NCS30    IF CONFUSION WITH STATEMENT NUMBER TAG 
          MX0    L.SHC
          BX6    X0*X6       HIGH L.SHC BITS ONLY 
          EQ     NCS15       PROCESS AS SHORT CONSTANT
  
 NCS.MOD  DATA   0           MODE BITS IF ADDWD CALLED. 
 PRS      SPACE  4,8
**        PRS -  PRESET AREA OF STORAGE.
*         DISASTER IF FWA IS GREATER THAN LWA.
*         STOLEN FROM *COMPASS VER 2.0* 
*         ENTRY  (X1) = DATUM 
*                (X2) = FWA.
*                (X3) = LWA+1.
*         USES   A6,A7  X0,X2,X3
  
  
 PRS      SUBR   0
          BX6    X1 
          IX0    X3-X2
          SX3    B1 
          SA6    X2 
          BX2    X0*X3
          AX0    1
          ZR     X0,PRSX     IF ONLY ONE WORD TO DO 
          BX7    X1 
          ZR     X2,PRS2     IF EVEN NR OF WORD TO PRESET 
          SA6    A6+B1
 PRS2     IX0    X0-X3
          SA6    A6+B1
          ZR     X0,PRSX     IF ONLY TWO WORDS
 PRS4     IX0    X0-X3
          SA7    A6+B1
          SA6    A7+1 
          NZ     X0,PRS4     IF NOT FINISHED
          EQ     PRSX        EXIT.. 
 SCD      SPACE  4,15 
**        SCTR - SCAN TRIPLE TABLE. 
* 
*                SCANS A TRIPLE-WORD TABLE, COMPARING ONLY ON THE FIRST 
*                WORD OF EACH ENTRY.
* 
*         ENTRY  (A1) _ TABLE TO BE SEARCHED. 
*                (X1) = ((A1))
*                (X6) = 60-BIT SEARCH ITEM
* 
*         IF SUCCESS -- 
*                (B7) = ORDINAL OF HIT. 
*                (A1) _ FIRST WORD OF MATCHING ENTRY. 
*                (X1) = (FIRST WORD OF MATCHING ENTRY). 
*                (A2) _ SECOND WORD OF MATCHING ENTRY.
*                (X2) = (SECOND WORD OF MATCHING ENTRY).
*                (X6) = (SECOND WORD OF MATCHING ENTRY).
* 
*         IF *NIT* -- 
*                (B7) = -3. 
*                (A1) PRESERVED.
*                (X1) PRESERVED.
*                (X6) PRESERVED.
* 
*         USES   A2,A3,A6  X0  B2,B7
  
  
  
 SCTR8    LX6    X3          RESTORE CLOBBERED   ((FWA)-2)
          SA6    A3 
          NO
          BX6    X2          RESTORE (X6) 
  
 SCTR     SUBR   0
          SA2    A1+N.TABLE 
          =B2    -3 
          SA3    X1+B2       ((FWA)-3)
          SA6    A3          STORE CRITERION IN SAVED CELL
          SB7    X1+B2
          SA2    X2+B7       FETCH LAST ENTRY 
  
 SCTR2    BX0    X6-X2
          SA2    A2+B2
          NZ     X0,SCTR2    IF NO HIT
  
          SB7    A2-B7       RELATIVE POSITION OF HIT 
          LX2    X6 
          MI     B7,SCTR8    IF DUMMY HIT 
          SA1    X1+B7
          =A2    A1+1 
          EQ     SCTR8       EXIT.. 
          SPACE  4,8
**        SCD -  SCAN DOUBLE TABLE. 
* 
*                SCANS A DOUBLE-WORD TABLE, COMPARING ONLY ON THE FIRST 
*         WORD OF EACH ENTRY. 
* 
*         ENTRY  (A1) _ TABLE TO BE SEARCHED. 
*                (X1) = ((A1))
*                (X6) = VALUE LOOKING FOR (ALL 60 BITS).
* 
*         IF SUCCESS -- 
*                (B7) = ORDINAL OF HIT. 
*                (A1) _ MATCHING ENTRY, FIRST WORD. 
*                (X1) = (MATCHING ENTRY, FIRST WORD). 
*                (A2) _ SECOND WORD OF MATCHING ENTRY.
*                (X2) = (SECOND WORD OF MATCHING ENTRY).
*                (X6) = (SECOND WORD OF MATCHING ENTRY).
* 
*         IF *NIT* -- 
*                (B7) = -2. 
*                (A1) PRESERVED.
*                (X1) PRESERVED.
*                (X6) PRESERVED.
* 
*         USES   A2,A3,A6  X0  B2,B7
*         NOTE THE SAVE AND RESTORE OF THE WORD BELOW THE SCANNED TABLE,
*                WHERE THE SEARCH OBJECT IS STORED.  THIS IS BECAUSE WE 
*                ARE NOT GUARANTEED TWO FREE WORDS BELOW A TABLE. 
  
  
  
 SCD8     LX6    X3          RESTORE CLOBBERED  ((FWA)-2) 
          SA6    A3 
          NO
          BX6    X2          RESTORE (X6) 
  
 SCD      SUBR   0
          SA2    A1+N.TABLE 
          =B2    -2 
          SA3    X1+B2       ((FWA)-2)
          SA6    A3          STORE CRITERION IN FIRST WORD
          SB7    X1+B2
          SA2    X2+B7       FETCH LAST ENTRY OF TABLE
  
 SCD2     BX0    X6-X2
          SA2    A2+B2
          NZ     X0,SCD2     IF NO HIT
  
          SB7    A2-B7       RELATIVE POSITION OF HIT 
          LX2    X6 
          MI     B7,SCD8     IF DUMMY HIT 
          SA1    X1+B7
          =A2    A1+1 
          EQ     SCD8        EXIT.. 
 SCS      SPACE  4,15 
**        SCS -  SCAN TABLE WITH SUPPLIED MASK. 
* 
*         ENTRY  (A1) TABLE TO BE SEARCHED
*                (X6) ENTRY LOOKING FOR IN GIVEN TABLE
*                (SCSA) = MASK TO BE USED.
*         EXIT   IF ENTRY *NIT*    - (B7) IS NEGATIVE.
*                                    (A1),(X1) PRESERVED. 
*                                    (X6) UNTOUCHED.
*                IF ENTRY *IT*     - (B7) ORDINAL OF MATCHING ENTRY.
*                (X2) ALL 60 BITS OF MATCHING ENTRY 
*                A2 _ TO MATCHING ENTRY 
*                (X6)  = (X2) .AND. MASK
*         USES   A2,A3,A6  X0,X1  B2,B7 
  
  
 SCS      SUBR   0
          SA2    A1+N.TABLE 
          SA3    SCSA 
          SA6    X1-1        STORE CRITERION BELOW TABLE
          SB7    A6 
          SA2    X2+B7       FETCH LAST ENTRY 
  
*         LOOP TILL MATCH FOUND 
  
 SCS1     BX0    X2-X6
          SA2    A2-B1       FETCH NEXT TABLE ENTRY 
          NO
          BX0    X3*X0       MASK 
          NZ     X0,SCS1     IF NOT HIT - LOOP
  
          SB7    A2-B7       RELATIVE POSITION OF ENTRY 
          SA2    A2+B1       TABLE ENTRY AT HIT 
          MI     B7,SCSX     IF DUMMY HIT - EXIT..
          BX6    X3*X2       MASK OFF 
          EQ     SCSX        EXIT.. 
  
 SCSA     DATA   0           MASK TO BE USED. 
 SCT      SPACE  4,8
**        SCT -  SCAN TABLE COMPARING ALL BITS. 
*                (MAINLY FOR USE WITH PAIRED TABLES)
*         ENTRY  (A1) TABLE TO BE SEARCHED
*                (X6) ENTRY LOOKING FOR IN GIVEN TABLE
*         EXIT   IF ENTRY *NIT*    - (B7) IS NEGATIVE.
*                                    (A1),(X1) PRESERVED. 
*                                    (X6) UNTOUCHED.
*                IF ENTRY *IT*     - (B7) ORDINAL OF MATCHING ENTRY.
*                (X2=X6) PAIRED  TABLE ENTRY
*                A2   _  PAIRED  TABLE ENTRY
*                A1   _  MASTER  TABLE ENTRY
*                (X1)    MASTER  TABLE ENTRY
*         USES   A1,A2,A6  X0  B1,B2
  
  
 SCT      SUBR   0
          SA2    A1+N.TABLE 
          =B2    -1 
          SA6    X1+B2       STORE CRITERION BELOW TABLE
          IX0    X1+X2
          NO
          SA2    X0+B2       FETCH LAST ENTRY 
          SB2    A6 
 SCT1     BX0    X6-X2
          SA2    A2-B1       FETCH NEXT TABLE ENTRY 
          NZ     X0,SCT1     IF NO HIT, LOOP
          MI     X0,SCT1     IF *0* - *-0* *HIT*
          SB7    A2-B2       RELATIVE POSITION OF ENTRY 
          SA2    A1+B1       TAG TABLE PARAMETERS 
          MI     B7,SCTX     IF DUMMY HIT 
          SB2    B2+B1       FIRST ADDRESS IN NAME TABLE
          SA2    X2+B7
          BX6    X2          TAG TABLE ENTRY
          SA1    B7+B2       NAME TABLE ENTRY 
          EQ     SCTX        EXIT.. 
 SSN      SPACE  4,12 
**        SSN -  SCAN *STATEMENT NUMBER* TABLE. (HASHED TABLE)
* 
*         ENTRY  A1 _ TABLE TO BE SEARCHED. 
*                (X6) = SYMBOL  (0LFORMAT)
*         EXIT   (B7) < 0 
*                (X6) = PRESERVED.
*                (A1)   PRESERVED.
*                (NEXT) _ ORDINAL OF NEXT ENTRY.
*                      IF < 0 - BASE CELL NOT OCCUPIED. 
*                      IF > 0 - BASE CELL OCCUPIED, MORE SPACE NEEDED.
*                (B7) > 0 
*                (X1) = MODE BITS.
*                (X2) = (X6) = TAG FOR SYMBOL.
*                (A1) = PRESERVED.
*                (A2) _ SYMBOL ENTRY. 
*         NOTE
*         CHAIN IS ON *SYMBOL* NOT TAG. 
* 
*         USES   A1,A2,A3  X0  B2,B7
  
  
 SSN10    SA2    A2+B1       TAG ENTRY. 
          MX0    -L.MODE
          BX6    X2 
          BX1    -X0*X2      MODE BITS. 
  
 SSN      SUBR   0
          BX3    X6 
          SA2    STNHASH
          AX3    12          ZERO EXPONENT
          PX0    X3 
          DX3    X2*X0
          SX0    LSTN-2 
          AX3    47-PSTN
          BX3    X0*X3       BASE INDEX 
          =B7    -1 
          SB2    X3 
          SA2    X1+B2       LOAD PROPOSED POSITION.
          BX0    X6 
          NZ     X2,SSN5     IF BASE CELL OCCUPIED. 
          SX3    B2 
          BX6    -X3
          SA6    NEXT        INDICATE BASE INDEX NOT OCCUPIED.
          LX6    X0          RESTORE *SYMBOL* 
          EQ     SSNX        EXIT.. 
  
 SSN5     IX0    X6-X2
          SB7    B2 
          AX0    P.SYM
          SB2    X2 
          ZR     X0,SSN10    IF MATCH.
          SA2    X1+B2
          NZ     B2,SSN5     LOOP UNTIL EMPTY CHAIN.
          BX0    X6 
          SX6    B7 
          =B7    -1          INDICATE NOT IN TABLE. 
          SA6    NEXT        INDICATE MOVE REQUIRED.
          LX6    X0 
          EQ     SSNX        EXIT.. 
  
 STNHASH  DATA   2525001001001001.BP0    TS.STN  HASH.
 SSY      SPACE  4,12 
**        SSY -  SCAN *SYMBOL* TABLE. (HASHED TABLE)
* 
*         ENTRY  A1 _ TABLE TO BE SEARCHED. 
*                (X6) = SYMBOL  (0LFORMAT)
*         EXIT   (B7) < 0 
*                (X6) = PRESERVED.
*                (A1)   PRESERVED.
*                (NEXT) _ ORDINAL OF NEXT ENTRY.
*                      IF < 0 - BASE CELL NOT OCCUPIED. 
*                      IF > 0 - BASE CELL OCCUPIED, MORE SPACE NEEDED.
*                (B7) > 0 
*                (X1) = MODE BITS.
*                (X2) = (X6) = TAG FOR SYMBOL.
*                (A1) = PRESERVED.
*                (A2) _ SYMBOL ENTRY. 
*         NOTE
*         CHAIN IS ON *SYMBOL* NOT TAG. 
* 
*         USES   A1,A2,A3  X0  B2,B7
  
  
 SSY10    SA2    A2+B1       TAG ENTRY. 
          MX0    -L.MODE
          BX6    X2 
          BX1    -X0*X2      MODE BITS. 
  
 SSY      SUBR   0
          MX0    CHAR 
          LX0    -LG.VAR*CHAR+CHAR
          BX3    X0*X6
          ZR     X3,SSY1     IF NOT SEVEN CHARACTER SYMBOL
          AX3    18 
          SB2    X3-1R+ 
          PL     B2,SSY1     IF APPENDED SPECIAL CHARACTER
          SA6    =XFILL.
          SA2    A1          SAVE *A* 
          ANSI   =XE.ANS2 
          SA1    A2          RESTORE *A1* 
 SSY1     BX3    X6 
          SA2    SYMHASH
          AX3    12          ZERO EXPONENT
          PX0    X3 
          DX3    X2*X0
          SX0    LSYM-2 
          AX3    47-PSYM
          BX3    X0*X3       BASE INDEX 
          =B7    -1 
          SB2    X3 
          SA2    X1+B2       LOAD PROPOSED POSITION.
          BX0    X6 
          NZ     X2,SSY5     IF BASE CELL OCCUPIED. 
          SX3    B2 
          BX6    -X3
          SA6    NEXT        INDICATE BASE INDEX NOT OCCUPIED.
          LX6    X0          RESTORE *SYMBOL* 
          EQ     SSYX        EXIT.. 
  
 SSY5     IX0    X6-X2
          SB7    B2 
          AX0    P.SYM
          SB2    X2 
          ZR     X0,SSY10    IF MATCH.
          SA2    X1+B2
          NZ     B2,SSY5     LOOP UNTIL EMPTY CHAIN.
          BX0    X6 
          SX6    B7 
          =B7    -1          INDICATE NOT IN TABLE. 
          SA6    NEXT        INDICATE MOVE REQUIRED.
          LX6    X0 
          EQ     SSYX        EXIT.. 
  
 NEXT     DATA   0           LOCATION OF NEXT ENTRY IN TABLE. 
  
 SYMHASH  DATA   2525001001001001.BP0    TS.SYM  HASH.
 SRT      SPACE  4,12 
**        SRT -  SORT SINGLE ENTRY TABLE. 
*         USES *SHELL* ALGORITHM (ACM JOURNAL 1960) 
*         ENTRY- A1 POINTS TO TABLE TO BE SORTED. 
*         EXIT-  TABLE IS SORTED
*         USES   A1,A2  X0  B2,B3,B4,B5,B6,B7 
  
  
 SRT      SUBR   0
          SA2    A1+N.TABLE 
          SX3    X2-2 
          MI     X3,SRTX     IF LESS THAN 2 ENTRIES - EXIT..
          SB7    X2          LENGTH OF TABLE TO  (I)
          SX7    X1-1        STARTING ADDRESS TO (Z)
          SB6    B7          LENGTH OF TABLE TO  (N)
 SRT5     SX0    B6 
          AX0    1
          SB6    X0          N= N/2 
          SB3    B1 
          ZR     B6,SRTX     IF N=0 DONE - EXIT.. 
          SB4    B7-B6       L=I-N
          SB2    B3          J=K
 SRT10    SB5    B2+B6       M=J+N
          SA1    X7+B2       A(J) 
          SA2    X7+B5       A(L) 
          IX6    X2-X1       A(L)-A(J)
          PL     X6,SRT15    IF A(L) .GE. A(J)
          BX6    X1 
          SA6    A2 
          LX6    X2 
          SA6    A1 
          SB2    B2-B6       J=J-N
          GT     B2,SRT10    IF J .GT. 0
 SRT15    SB3    B3+B1       K=K+1
          SB2    B3          J=K
          LE     B3,B4,SRT10 IF K .LE. L
          EQ     SRT5        LOOP THROU TABLE.
 DSRT     SPACE  4,12 
**        DSRT-  SORT DOUBLE ENTRY TABLE. 
*         USES *SHELL* ALGORITHM (ACM JOURNAL 1960) 
*         ENTRY- A1 POINTS TO TABLE TO BE SORTED. 
*         EXIT-  TABLE IS SORTED
*         USES   A0,A1,A2,A3,A4,A7  X0  B2,B3,B4,B5,B6,B7 
  
  
 DSRT     SUBR   0
          SA2    A1+N.TABLE 
          SX3    X2-2 
          MI     X3,DSRTX    IF LESS THAN 2 ENTRIES - EXIT..
          SB7    X2          LENGTH OF TABLE TO  (I)
          SA0    X1-2        STARTING ADDRESS TO (Z)
          SB6    B7          LENGTH OF TABLE TO  (N)
 DSRT5    SX0    B6 
          AX0    2           /4 
          =B3    2
          LX0    1           /2 
          SB6    X0          N= N/2 
          ZR     B6,DSRTX    IF N=0 EXIT..
          SB4    B7-B6       L=I-N
          SB2    B3          J=K
 DSRT10   SB5    B2+B6       M=J+N
          SA1    A0+B2       A(J)  (SYMBOL ENTRIES) 
          SA2    A0+B5       A(L) 
          IX6    X2-X1       A(L)-A(J)
          PL     X6,DSRT15   IF A(L) .GE. A(J)
          SA3    A1+B1             (TAG ENTRIES)
          SA4    A2+B1
          BX6    X1 
          LX7    X3 
          SA6    A2          (SYMBOL) 
          SA7    A4          (TAG   ) 
          LX6    X2 
          BX7    X4 
          SA6    A1          (SYMBOL) 
          SA7    A3          (TAG   ) 
          SB2    B2-B6       J=J-N
          NO
          GT     B2,DSRT10   IF J .GT. 0
 DSRT15   SB3    B3+2        K=K+2
          NO
          SB2    B3          J=K
          LE     B3,B4,DSRT10 IF K .LE. L 
          EQ     DSRT5       LOOP THRU TABLE. 
  
          LIST   D
          END 
