*DECK     DPCLOSE 
          IDENT  DPCLOSE
          TITLE              DPCLOSE - TERMINATE DECLARATIVE PROCESSING 
*CALL     SSTCALL 
 B=DPCLS  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
 SYM1     EQU    12B
 SYMEND   EQU    13B
 DIM1     EQU    17B
 PROGRAM  EQU    RA.SSW+56B        PROG    12/2000B,48/0
*                                  BLKDTA  60/0 
*                                  SUBR    12/2001B,48/0
*                                  FUNC    12/2002B,48/0
  
          ENTRY  DPCLOSE,O.CBT
  
          EXT    PH2CTL,R=FLAG,MACFLAG,DFLAG
          EXT    ASAER,ERPROI,ERPRO,ST. 
          EXT    VARDIM,SCF,SEF 
  
          EXT    SYMORD,C.BLOCK,DATA..
          EXT    ORGTAB,N.COM,OSC,PSYM,CON. 
          EXT    INITBL 
          EXT    LOWCORE
          EXT    N.FILES
          EXT    N.FP 
          EXT    WB.CON 
          EXT    F.LFN
          EXT    CTBLOVL           MEMORY OVERFLOW EXIT 
 PH1MO    EQU    CTBLOVL
  
          TABLES DIM,EQV,COM,LAT,SCA,ECT,FPBL,ENTR
          TABLES EOT
          EXT    S.SCA,S.LAT,S.EQV,S.ECT
          SPACE  3
          USE    CODE              TO FORCE THE LITERALS TO COME FIRST
  
          EJECT 
**        DPCLOSE IS CALLED BY PH1CTL TO PROCESS THE ACCUMULATED
*         DECLARATIVE INFORMATION WHEN THE FIRST NON-SPECIFICATION
*         STATEMENT IS ENCOUNTERED. 
* 
*         IT FUNCTIONS ARE TO:  
*           ASSIGN ADDRESS"S AND ALLOCATE STORAGE FOR ARRAYS, 
*           COMMON BLOCKS AND EQUIVALENCE CLASS"S.
*           IF R OPTION IS SELECTED, THEN FORMAT AND SAVE NECESSARY 
*           INFORMATION SO THAT THE COMMON BLOCK AND EQUIVALENCE
*           CLASS MEMBERS MAY BE PRINTED OUT
*           ISSUE STORAGE TO "COMPS" IF  NECESSARY
* 
*           INITIALIZE FOR PHASE 2
* 
          SPACE  3
*         ERROR MESSAGES
  
 E.FPNI   EQU    201               PREVIOUS MENTIONED ADJUSTABLE SUBSC
*                                  NOT TYPE INTEGER 
 E.LECS   EQU    202               ALL ECS VARIABLES MUST BE IN COMMON
 E.BLKL   EQU    288               COMMON BLOCK LENGTH TOO LONG 
 E.CLC    EQU    292               CONFLICTING LEVELS IN COMMON 
 E.NAL    EQU    293               NOT ALL ITEMS IN BLOCK LEVELED 
 E.LEE    EQU    294               LEVEL EQUIVALENCE ERROR
 E.EQVL   EQU    298               COMMON-EQUIVALENCE EXTENSION ERROR 
  
*         EQV ERRORS
  
 E.RER    EQU    95                REDUNDANT EQUIVALENCE RELATIONSHIP 
 E.E1N    EQU    92                ONLY ONE NAME IN EQUIVALENCE CLASS 
 E.S>D    EQU    96                N.SUBS > N.DIMS
 E.CBE    EQU    97                ILLEGAL COMMON BLOCK EXTENSION 
 E.CER    EQU    98                CONTRADICTORY EQUIV RELATIONSHIP 
 E.NOS    EQU    214               NO SUBS, FIRST ELEMENT USED
 E.DRE    EQU    229               DIM RANGE EXTENDED ( INFORMATIVE ) 
          SPACE  4
*         GLOBAL COMMUNICATIONS CELLS.
  
 DBLDECL  ENTRY. 0                 .NZ. IF DBL OR CPLX DECL STMTS FOUND 
  
*         DEFINE MIN LCM RESIDENT LEVEL.
  
 #DAL     IFEQ   .DAL,1            IF DIRECT-ACCESS LCM AVAILABLE.
 MN.LCM   EQU    2
 #DAL     ELSE
 MN.LCM   EQU    3
 #DAL     ENDIF 
 SCNT     EQU    46B               DIAGNOSTIC LINE NUMBER (LOW CORE)
 SAVESCNT BSS    1                 TEMPORARY FOR SCNT DURING DPCLOSE
          TITLE              TABLES 
**        TABLE DESCRIPTIONS
  
  
**        CBT -  COMMON BLOCK INDEX TABLE, A COPY OF ORGTAB DURING
*                PHASE 1 FOR REFMAP.
*                NEEDED ONLY WHEN R OPTION SELECTED.
          SPACE  4,10 
**        COM -  COMMON TABLE.
*                NEEDED ONLY WHEN R OPTION SELECTED.
  
  
          DESCRIBE CH.,60    COMMON BLOCK HEADER WORD 
 EQU      DEFINE 1           EQUIVALENCE BIT
 CLC      DEFINE 1           E.CLC BIT
 NAL      DEFINE 1           E.NAL BIT
 LEE      DEFINE 1           E.LEE BIT
 EVL      DEFINE 1           E.EQVL BIT 
          DEFINE 1
 LEN      DEFINE 18          BLOCK LENGTH 
 NM       DEFINE 18          NO. MEMBERS
 LNK      DEFINE 18          LINK TO NEXT BLOCK APPEARENCE
  
          DESCRIBE CM.,60    COMMON BLOCK MEMBER WORD 
 DM       DEFINE 1           DIMENSION BIT
          DEFINE 5
 WC       DEFINE 18          NO. WORDS
 SYM      DEFINE 18          SYMORD 
 RA       DEFINE 18 
          SPACE  4,10 
**        DIM -  DIMENSION TABLE. ENTRIES FOR EQUIVALENCED VARIABLES
*                ADDED IN PDC. BIAS, RA ARE COMPUTED IN EQV.
  
  
          DESCRIBE D1.,60    DIM TABLE WORD 1 
 LOC      DEFINE 1           LOCAL BIT
          DEFINE 5
 SYM      DEFINE 18          SYMORD 
 BIA      DEFINE 18          BIAS (FOR CLASS MEMBER)
 SPN      DEQU   BIA         SPAN (FOR CLASS BASE)
 RA       DEFINE 18 
  
          DESCRIBE D2.,60    DIM TABLE WORD 2 
 ND       DEFINE 3           NO. DIMENSIONS 
 NVS      DEFINE 3           NO. VARIABLE SUBSCRIPT 
 WC       DEFINE 18          NO. WORDS
 SB       DEFINE 18          SUBSCRIPT A
 SA       DEFINE 18          SUBSCRIPT B
          SPACE  4,10 
**        ECT -  EQUIVLALENCE CLASS TABLE, CREATED IN SCAN5 OF EQV, 
*                ONE ENTRY FOR EACH EQUIVALENCED VARIABLE.
*                TEMPORARY ENTRIES ARE FORMED FIRST TO SORT OUT THE 
*                CLASSES AND TO FIND THEIR BASE MEMBERS.
*                CONTENTS ARE COPIED TO EQV TABLE AT END OF EQV.
*                NEEDED WHEN R OPTION IS SELECTED.
  
  
          DESCRIBE TE.,60    TEMPORARY EQUIVALENCE CLASS TABLE
 EOI      DEFINE 16          INDEX TO EOT ENTRY 
          DEFINE 7           0
 CBB      DEFINE 1           COMMON BASE BIAS (0 IF COMMON BASE)
 BIA      DEFINE 18          BIAS 
 GFA      DEFINE 18          G-F TABLE ENTRY ADDRESS
  
          DESCRIBE EC.,60    ECT
 CB       DEFINE 1           COMMON BIT(BASE) 
          DEFINE 5
 WC       DEFINE 18          NO. WORDS(MEMBER)
 SPN      DEQU   WC          SPAN(BASE) 
 SYM      DEFINE 18 
 BIA      DEFINE 18          BIAS(MEMBER) 
 NM       DEQU   BIA         NO. MEMBERS(BASE)
          SPACE  4,10 
**        EOT -  EQUIVALENCE OVERLAP TABLE. 
*                ONE ENTRY PER EACH EQUIVALENCE CLASS.
*                CREATED IN SCAN2 OF EQV FOR EQUIVALENCE OVERLAP
*                SEARCHES.
*                EXISTS ONLY DURING EQV.
  
  
          DESCRIBE EO.,60 
 RB       DEFINE L.RB+1 
 FWA      DEFINE 18          FWA OF CLASS 
 LWA      DEFINE 18          LWA OF CLASS 
 GFI      DEFINE 24-L.RB-1         G-F TABLE INDEX OF ROOT
          SPACE  4,10 
**        EQV -  EQUIVALENCE TABLE, CREATED FROM EQUIVALENCE SOURCE 
*                IN DPEQU OF *DECPRO*.
*                CHANGED TO G-F TABLE IN SCAN1 OF EQV.
*                CONTAINS FINAL EQUIV INFORMATION NEEDED FOR REFMAP.
*                NEEDED WHEN EDIT OPTION IS SELECTED. (LOCAL TO 
*                *DPCLOSE*. 
  
  
          DESCRIBE E1.,60    EQV TABLE WORD 1 (ENTRY TO EQV)
 GOR      DEFINE 16          GROUP ORD
 SY2      DEFINE 44          2*SYMORD 
  
          DESCRIBE E2.,60    EQV TABLE WORD 2 (ENTRY TO EQV)
 NS       DEFINE 3           NO. SUBSCRIPT
          DEFINE 3
 SC       DEFINE 18          SUBSCRIPT C
 SB       DEFINE 18          SUBSCRIPT B
 SA       DEFINE 18          SUBSCRIPT A
  
          DESCRIBE Q2.,60    EQV TABLE WORD 2 (AFTER PRESCAN) 
 GOR      DEFINE 16          GROUP ORD
          DEFINE 8
 PD       DEFINE 18          PRODUCT OF DIMENSIONS (PI(DIMS)) 
 SUB      DEFINE 18          SUBSCRIPT
  
          DESCRIBE G1.,60    G-F TABLE WORD 1 (AFTER SCAN1) 
          DEFINE 5           0
 COM      DEFINE 1           COMMON BIT 
 SYM      DEFINE 18          SYMORD 
 RB       DEFINE 18 
 RA       DEFINE 18 
 ADR      DEQU   RA,36       RB/RA
  
          DESCRIBE G2.,60    G-F TABLE WORD 2 (AFTER SCAN1) 
 P        DEFINE 16          P(I), WHERE P(I)= PARENT OF I
          DEFINE 8
 HI       DEFINE 18          LENGTH ABOVE THE MEMBER
 LO       DEFINE 18          LENGTH BELOW THE ROOT
  
          DESCRIBE F2.,60    G-F TABLE WORD 2 (AFTER SCAN4) 
          DEFINE 8
 EOI      DEFINE 16          EOT INDEX OF BASE
 BIA      DEFINE 18          BIAS 
 FWA      DEFINE 18          FWA OF CLASS 
  
  
*CALL FMACDEF 
  
  
*         USE    /MACBUF/          DEFINITION FOR ALL *DPCLOSE* EXCEPT
*                                  FOR *ETC* WHICH USES THE DEFINITION
*                                  IN *FMACDEF* (LISTED IN *STMTP*).
  
          LOC    NARGS             FWA OF /MACBUF/ AS DEFINED IN
*                                  *FMACDEF*. 
  
*                           LEN 
 TEMP     EQU    *           1     A TEMPORARY
 ECSCOM   EQU    *+1         1     NE 0 IF ECS VARIABLE NOT IN COMMON 
 LCMERR   EQU    *+2         1
 LCMORD   EQU    *+3         1
  
 PSEUDO   EQU    *+4         1     PSEUDO OP WORD 
 CLI      EQU    *+5         2     LOOP INDEX AND LIMIT FOR COMMON
 CLOC     EQU    *+7         2     CURRENT LOC AND LINK 
 CBUF     EQU    *+9         4     SPACE FOR *EQV*
 NSCR     EQU    *+13-TEMP         LEN OF /MACBUF/
          LOC    *O 
          TITLE              MAIN LOOP
 DPCLOSE  SA1    =10R  EQV/COMM    REPLACES DIAG LINE NUMBER
          SA2    SCNT              FOR MESSAGES OUTPUT DURING DPCLOSE 
          BX6    X1 
          SA6    A2 
          BX6    X2 
          SA6    SAVESCNT          SAVE DIAG LINE NUMBER
          RJ     SCF
          RJ     SEF               ADJUST EQVTAB LENGTH 
          SX6    O.CET
          RJ     INITBL            INITIALIZE TABLES FOR DPCLOSE
  
          RJ     ETC               ISSUE TRACEBACK, ENTRYPOINT, AND F.P.
*                                  INFO TO COMPS FOR SUBPROGRAMS
  
          MX7    0
          SB1    NSCR 
+         SA7    TEMP-1+B1         CLEAR OUT SCRATCH CELLS AND FLAGS
          SB1    B1-B5
          NZ     B1,*-1 
  
          RJ     PDC               PERFORM DEFERRED CHECKS
  
          RJ     ACA               ASSIGN COMMON ADDRESS S
  
          RJ     EQV               PROCESS EQUIVALENCE TABLES 
  
          RJ     ALA               ASSIGN LOCAL ADDRESS S 
  
          RJ     PCE         PROCESS COMMON ERRORS
  
          RJ     SCA               SAVE COMMON ADDRESS S
  
          RJ     ISC               ISSUE STORAGE TO COMPS 
  
*         INITIALIZE FOR PHASE 2
  
          SA1    O.TBLS 
          BX6    X1 
          MX7    0
          SA4    R=FLAG 
          SX5    X4-3 
          ZR     X5,DPC1           IF R = 3 
          SA7    L.COM
 DPC1     SA7    L.LAT
          RJ     INITBL            INITIALIZE TABLES
  
          SA3    O.DIM
          SX6    X3-2 
          SA6    DIM1              DIM1 = O.DIM-2 
          SA1    O.FPBL 
          SA2    N.FP 
          BX7    X2 
          SB1    X1                FWA
          SB2    B1+X2
          MX6    0
          SA7    L.FPBL            L.FPBL = N.FP
  
+         SA6    B1                CLEAR THE F.P. BLOCK LENGTH TABLE
          SB1    B1+B5
          LT     B1,B2,*
  
*         SET UP ENTRY POINT TABLE
  
          SA1    PROGRAM
          ZR     X1,DPC2           IF A BLOCK DATA SUBPROGRAM 
          SX1    1           SYMTAB ORD OF ENTRY POINT=PROG UNIT NAME 
          ADDWD  ENTR,X1
          SA5    N.FILES
          ZR     X5,DPC2           IF NO FILES
          SA4    F.LFN
          LX4    59-P.EXT 
          PL     X4,DPC2           IF FILES IN A MAIN PROG ARE NOT
*                                  ENTRY POINTS 
          ALLOC  ,X5               GET SPACE
  
          SA1    O.ENTR 
          SA2    N.FILES
          SX7    X2+B5
          SA7    L.ENTR            L.ENTR = N.FILES+1 
          SB1    X1 
          SB2    B1+X7             LWA+1
          SX6    2                 ORDINAL OF FIRST FILE
  
+         SB1    B1+B5             ADD ORDINALS OF FILE NAMES TO ENTR TB
          SA6    B1 
          SX6    X6+B5
          LT     B1,B2,*-1
  
 DPC2     SYMBOL =8RCON.           CON. TO SYMTAB 
          SA3    WB.CON            TYPE , RL AND RB 
          BX7    X3+X2
          SA7    A2 
          SX6    B1                SAVE SYMTAB ORDINAL
          SA6    CON. 
  
          SA5    DFLAG
          ZR     X5,DPC3           IF NOT DEBUG MODE
          CALL   DINPH2            INITIALIZE FOR DEBUG PROCESSOR 
          SA1    =XN.FERR 
          ZR     X1,DPC3           IF NO FATAL ERRORS IN PHASE 1
          MX7    1
          SA7    =XP2NOGO    SET *SUPPRESS OBJECT CODE GENERATION*
  
 DPC3     OUTUSE DATA.             SET RELOCATION BASE
          SA1    SAVESCNT          RESTORE DIAG LINE NUMBER 
          BX6    X1 
          SA6    SCNT 
          EQ     PH2CTL            EXIT TO PHASE 2
  
  
 O.CBT    EQU    DPCLOSE+150       FWA OF SAVED COMMON BLOCK TABLE
 O.TBLS   VFD    60/O.CBT          FWA OF TABLES AFTER MOVE 
 BLKNAM   DATA   17L  USE    /NAME/ 
 LCMBLK   DATA   17L  USELCM /NAME/ 
 TEMPREG  BSS    1
          TITLE              ISC - ISSUE STORAGE TO COMPS 
**        ISC - ISSUE STORAGE TO COMPS
* 
*         ON ENTRY: 
*         COMTAB: 
*                HEADER WORD: 1/EQVFLAG,5/0,18/BLK LEN,18/MEMS,18/LINK
*                MEMBERS:  1/DIMFLAG,5/0,18/WC,18/SYMORD,18/RA
*                ECS:      1/D,5/0,18/ECS RA,18/SYMORD,18/CM RA 
* 
*         LAT:  
*                          6/0,18/WC,18/SYMORD,18/0 
* 
 ISC
          SA1    MACFLAG
          SA2    =XLEVEL
+         NZ     X2,*+1            IF WE HAVE AN ECS BLOCK
          ZR     X1,ISC            IF COMPS OPTION NOT ON 
  
*         OUTPUT "COMPS" IMAGES FOR THE COMMON DECLARATIONS 
  
          SA1    N.COM
          ZR     X1,ISC.L          IF NO COMMON 
          SX6    O.CBT
          SA6    C.BLOCK           TO FORCE AN USE DATA. LATER
          IX7    X1+X6
          SA6    CLI               LOOP INDEX 
          SA7    A6+B5             LIMIT
  
 ISC1     SA4    X6                BLOCK NAME 
          MX0    L.NAME 
          SB7    BLKNAM 
          BX7    X0*X4
  
*         DETERMINE IF THIS IS AN LCM/ECS BLOCK 
  
          SA3    O.COM
          IX4    X3+X4
          SA5    X4+B5
          SA3    SYM1 
          AX5    18-1              2*SYMORD 
          SX4    X5+B5             2*SYMORD+1 
          IX3    X3-X4
          SA4    X3                WORD B 
          LX4    59-P.LCM 
          BX6    X4 
          SA6    LCMORD 
          PL     X6,ISC1.A   IF NOT ECS/LCM 
          SB7    LCMBLK 
  
 ISC1.A   SA5    =3R  / 
          BX7    X5+X7
          LX7    54                /NAME BB 
          SB6    6
          SB2    B6 
          MX6    54 
+         SB2    B2+B6             FIND THE LAST NON BLANK CHAR 
          AX5    B2,X7
          BX4    -X6*X5 
          SX3    X4-1R
          ZR     X3,*-1            LOOP IF A BLANK
          LX7    6
          SX5    1R/-1R 
          LX5    B2,X5
          IX7    X7+X5
          MX6    L.NAME+6 
          BX7    X6*X7
          SA7    B7+B5
          SB6    B7                (B6) = LINE FWA
          SB1    1
          WRITEC =XF.CMPS,B6,2     * USE BLKNAM* TO -COMPS- 
  
*         CHECK FOR AN EQUIVALENCED BLOCK 
  
          SA5    CLI
          SA4    O.COM
          SA3    X5                INDEX TO COMTAB
          SB5    B1 
          IX6    X3+X4
          SA1    X6                COMTAB HEADER WORD 
          SA6    CLOC 
          BX4    X1 
          MX3    0
          MX0    17 
          LX0    17+36
          SA4    A1          COMTAB HEADER
  
 ISC1C    SB4    X4          INDEX TO NEXT HEADER 
          AX4    18 
          SB1    X4          NUMBER OF ENTRIES
  
 ISC1D    SA2    A4+B1
          BX2    X0*X2
          IX3    X3+X2
          SB1    B1-B5
          GT     B1,B0,ISC1D
          SA4    A4+B4       NEXT COMTAB HEADER 
          NE     B4,ISC1C 
          BX2    X0*X1
          IX7    X2-X3       ACTUAL LENGTH - DECLARED LENGTH
          AX7    36 
          SA7    TEMP 
          SA2    LCMORD 
          SA3    =XDIRECT 
          ZR     X3,ISC1.B   IF DIRECT MODE 
          MI     X2,ISC2     IF LCM/ECS 
 ISC1.B   SX7    X1 
          SA7    A6+B5             LINK 
          EQ     ISC3 
  
*         ISSUE STORAGE FOR A LEVEL 3 BLOCK 
  
 ISC2     SX2    X5-O.CBT+1 
          SB1    54 
          SX7    1R?
          RJ     =XCNVT 
          MX0    1
          SB2    B1-B5
          SA5    =10H 
          AX0    B2,X0
          BX2    X0*X5
          IX7    X2+X7       PAD WITH BLANKS
          LX6    B1,X7             X6 = LABEL IN 7LNAME FORM
          MX0    42 
          AX1    36 
          SA5    BSS.OP            BSS OPCODE 
          BX6    X0*X6       FORCE TO 7L FORM 
          MX7    60-17
          BX1    -X7*X1            BLOCK LENGTH 
          RJ     =XWST             ISSUE ?NNN BSS MMMB TO COMPS 
          EQ     ISC5 
  
 ISC3     SA5    BSS.OP 
          BX7    X5 
          SA7    PSEUDO 
  
*         ISSUE *NAME BSS NNNB* FOR EACH OCCURRENCE OF EACH BLOCK NAME. 
  
 ISC4     SX6    A1+B5             FWA
          AX1    18 
          SX7    X1                NUMBER OF MEMBERS
          RJ     OSC               OUTPUT STORAGE 
          SA5    PSEUDO 
          SA2    CLOC 
          SA3    A2+B5             LINK 
          IX6    X2+X3
          SA6    A2 
          SA1    X6                BLOCK HEADER 
          SX7    X1 
          SA7    A3                NEW LINK 
          NZ     X3,ISC4           IF MORE OCCURRENCES
  
 ISC5     SA1    TEMP 
          ZR     X1,ISC6     IF NO EXTRA BSS NECESSARY
          MI     X1,ISC6
          MX0    42 
          SA5    BSS.OP 
          SA4    =7L
          BX6    X4 
          RJ     =XWST       GENERATE BSS 
  
 ISC6     SA1    CLI
          SA2    A1+B5             LIMIT
          SX6    X1+B5
          IX0    X6-X2             I - L
          SA6    A1 
          NG     X0,ISC1           IF MORE BLOCKS TO GO 
  
 ISC.L    OUTUSE DATA..            SET RELOCATION BASE
          SA1    O.LAT
          SA2    L.LAT
          ZR     X2,ISC            IF NO LOCAL ARRAYS 
          SA5    BSS.OP 
          BX6    X1 
          LX7    X2 
          RJ     OSC               OUTPUT STORAGE FOR THE LOCAL ARRAYS
          EQ     ISC
  
 BSS.OP   VFD    12/2LS ,30/48,18/3L BS 
          TITLE              SCA - SAVE COMMON ADDRESS S
  
**        SCA - SET/SAVE COMMON ADDRESS"S 
* 
  
 SCA
          SA1    N.COM
          ZR     X1,SCA            IF NO COMMON BLOCKS
  
*         INSTALL BLOCK LENGTH IN ORGTAB, SAVE INDEX TABLE FOR REFMAP 
  
          SB6    ORGTAB 
          SB7    B6+X1             LWA+1
          MX0    L.NAME 
          SB1    O.CBT             FWA OF SAVED INDEX TABLE 
          SA5    O.COM
  
 SCA1     SA1    B6                ORGTAB ENTRY 
          IX2    X5+X1             O.COM+ORGTAB(I)
          SA3    X2 
          BX6    X0*X1             EXTRACT NAME 
          AX3    36 
          BX4    -X0*X3            EXTRACT BLOCK LENGTH 
          LX7    X1 
          IX6    X6+X4
          SA6    A1                UPDATE ORGTAB ENTRY
          SA7    B1                SAVE INDEX 
          SB6    B6+B5
          SB1    B1+B5
          LT     B6,B7,SCA1        IF NOT FINISHED
          SA5    R=FLAG 
          SX5    X5-3 
          NZ     X5,SCA2           IF R " 3 
          SX6    B1 
          SA6    O.TBLS            UPDATE FWA OF TABLES AFTER MOVE
          SA6    LOWCORE
  
 SCA2     ALLAE  SCA               ALLOCATE ALMOST EVERYTHING 
          SA1    O.SCA
          SB6    X1                B6 = O.SCA 
          SB7    B0                L.SCA = 0
          SA4    S.SCA
          SB4    X4          B4 = SCA TABLE SPACE LEFT
  
*         LOOP THROUGH COMTAB AND INSTALL ADDRESS"S OF MEMBERS
*         THAT DO NOT HAVE A DIM ENTRY IN SYMTAB
  
          SA1    O.COM
          SA2    L.COM
          SB1    X1                FWA
          SB2    B1+X2             LWA+1
          SA5    SYM1 
          SX0    B5+B5
          LX0    P.RL              X0 = RL FOR A COMMON BLOCK 
          SA0    X5-1              A0 = SYM1-1
  
          SA4    DFLAG
  
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          SA5    =XDIRECT 
          SX7    V.SCA
 #DAL     ENDIF 
  
          NZ     X4,SCA7     IF DEBUG MODE
  
 SCA4     SA1    B1                BLOCK PREFIX WORD
          AX1    18 
          SB3    X1                NUMBER OF NAMES IN THE GROUP 
  
 SCA5     SA1    A1+B5             MEMBER 
          SB3    B3-B5
          NG     X1,SCA6           IF THIS MEMBER HAS A DIM ENTRY 
  
          SX2    X1          RELATIVE ADDRESS 
          AX1    18-1 
          SB1    X1 
          LX2    P.RA 
          SA4    A0-B1             WORD B 
          IX7    X0+X2             RL+RA
          BX6    X7+X4
          SA6    A4                UPDATE SYMTAB ENTRY
  
 SCA6     NZ     B3,SCA5           IF MORE TO GO
          SB1    A1+B5
          LT     B1,B2,SCA4 
  
          SX7    B7 
          SA7    L.SCA
          EQ     SCA
  
  
*         DEBUG VERSION OF LOOP.
  
 SCA7     SA1    B1          BLOCK PREFIX WORD
          AX1    18 
          SB3    X1          NUMBER OF NAMES IN GROUP 
 SCA8     SA1    A1+B5       MEMBER 
          SB3    B3-B5
          MI     X1,SCA9     IF THIS MEMBER HAS A DIM ENTRY 
          BX6    X1 
          SX2    X1          RELATIVE ADDRESS 
          AX1    18-1 
          SB1    X1 
          SA6    B6+B7       SAVE COMTAB ENTRY
  
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
* 
*         FORM LINK IN DIMP FIELD OF SYMTAB TO SCA ENTRY, FOR USE BY
*         PASS 1 ROUTINES FORMING INDIRECT-MODE LCM ADDRESSES.
* 
          ZR     X5,SCA8.A   IF DIRECT MODE 
          SA4    A0-B1       WORD B 
          LX4    59-P.LCM 
          PL     X4,SCA8.A   IF NOT LCM RESIDENT
          LX4    P.LCM-59    RESTORE WORD B 
          BX4    X4+X7       MARK DIMP = SCAP 
          SX6    B7 
          LX6    P.DIMP 
          BX6    X4+X6       DIMP = L.SCA 
          SA6    A4          RESET WORD B 
 SCA8.A   BSS    0
 #DAL     ENDIF 
  
          SB7    B7+B5       L.SCA = L.SCA + 1
          SB4    B4-B5       DECREMENT TABLE SPACE REMAINING
          MI     B4,PH1MO    IF OVERFLOW
 SCA9     NZ     B3,SCA8     IF MORE TO GO
          SB1    A1+B5
          LT     B1,B2,SCA7 
          SX7    B7 
          SA7    L.SCA
          EQ     SCA
  
  
          SPACE  3
**        CODE AFTER THIS POINT IS OVERLAID IN "SCA"
* 
          IFGT   *,O.CBT,1
          ERR    CODE IS TO LONG, YOU ARE IN TROUBLE
          TITLE  PCE - PROCESS COMMON ERRORS
**        PCE - PROCESS COMMON ERRORS 
* 
  
 PCE      ENTRY. *
          SA1    N.COM
          ZR     X1,PCE      IF NO COMMON BLOCKS
          SB6    ORGTAB 
          SB7    B6+X1       LWA + 1
          MX0    L.NAME 
          SA5    O.COM
  
 PCE1     SA1    B6          ORGTAB ENTRY 
          IX2    X5+X1       O.COM+ORGTAB(I)
          SA3    X2 
          BX6    X0*X1
          MX4    1
          LX4    1+CH.EVLP
          SB2    E.EQVL 
          BX7    X4*X3
          NZ     X7,PCE.E    IF EQUIVALENCED COMMON BLOCK LENGTH ERROR
          LX4    CH.LEEP-CH.EVLP
          SB2    E.LEE
          BX7    X4*X3
          NZ     X7,PCE.E    IF LEVEL CONFLICT IN EQUIVALENCING 
          LX4    CH.CLCP-CH.LEEP
          BX7    X4*X3
          SB2    E.CLC
          NZ     X7,PCE.E    IF LEVEL CONFLICT IN COMMON BLOCK
          LX4    CH.NALP-CH.CLCP
          SB2    E.NAL
          BX7    X4*X3
          NZ     X7,PCE.E    IF NOT ALL MEMBERS LEVELED 
          SB6    B6+B5
          LT     B6,B7,PCE1  IF NOT FINISHED
          EQ     PCE
  
 PCE.E    SX2    1R 
          BX7    -X4*X3 
          LX6    60-12
          SA7    A3 
          BX3    X6+X2       FILL NAME TO EIGHT CHARACTERS
          SX7    B6 
          SX6    B7 
          SA7    CBUF        SAVE NECESSARY REGISTERS 
          SB6    B2 
          SA6    A7+B5
          MX4    0
          SB2    E.NAL
          NE     B2,B6,PCE.E0 
          POSTER SEV=INF,NR=**,RETURN=PCE.E1
  
 PCE.E0   POSTER SEV=FE,NR=** 
  
 PCE.E1   SA2    CBUF        RESTORE REGISTERS
          MX0    L.NAME 
          SA1    A2+B5
          SB6    X2 
          SB7    X1 
          SA5    O.COM
          EQ     PCE1 
          TITLE              ALA - ASSIGN LOCAL ADDRESS S 
**        ALA - ASSIGN LOCAL ADDRESS"S
* 
*         SCAN SYMTAB FOR LOCAL SYMBOLS WITH NON-ZERO DIMP FIELDS 
*         AND ^ ( COM OR EQV )
*         ASSIGN ADDRESS"S, INCREMENT BLOCK LENGTH
*         SAVE SYMTAB ADDRESS"S IN A TEMPORARY TABLE IN CASE WE HAVE TO 
*         ISSUE COMPS STORAGE 
* 
 ALA      ENTRY. *                 ** ENTRY/EXIT ** 
          SA4    MACFLAG
          NZ     X4,ALA0           IF WE HAVE TO ISSUE COMPS STORAGE
          PLUG   AT=ALA.P,TO=ALA1  PLUG SKIPS ISSUING STORAGE TO CMPS 
  
 ALA0     ALLAE  LAT               GET SPACE
          SA1    O.LAT
          SA2    L.LAT
          SA3    S.LAT
          SB6    X1                B6 = FWA 
          SB7    X2                B7 = INDEX 
          SB4    X3                B4 = SPACE ALLOCATED 
          SA1    DATA.. 
          SA3    ST.
          SA4    SYM1 
          SA5    SYMORD 
          LX3    1
          SA0    X4                A0 = SYM1
          SB1    X3                B1 = INDEX = 2*ORD(ST.)
          LX5    1
          SB2    X5                B2 = LIMIT = 2*(N.SYMBOLS+1) 
          BX7    X1                X7 = BLOCK LENGTH
  
          MX0    L.DIMP 
          SX5    V.COM+V.EQU
          LX0    L.DIMP+P.DIMP     TO EXTRACT THE DIMP FIELD
          SA3    O.DIM
          SB3    X3-2              B3 = INDEX TO DIMTAB 
          SPACE  3
 ALA1     SA1    A0-B1
          GE     B1,B2,ALAX        IF FINISHED
          SA2    A1-B5             WORD B 
          BX3    X5*X1
          SB1    B1+2 
          BX6    X0*X2             EXTRACT DIMP ORD 
          NZ     X3,ALA1           IF COM OR EQV
          MX1    -L.LVL 
          LX2    -P.LVL 
          BX1    -X1*X2 
          SX4    X1-2 
          PL     X4,ALA.E    IF LEVEL = 2 OR 3
          AX2    P.TYP-P.LVL
          SX4    X2-T.LAB 
          ZR     X6,ALA1           IF NOT DIMENSIONED 
          PL     X4,ALA1           IF A FORMAT LABEL
          AX6    P.DIMP-1 
  
*         ASSIGN ADDRESS TO LOCAL ARRAY 
  
          SA3    B3+X6             WORD 1 OF DIM ENTRY
          NG     X3,ALA1           IF AN EQUIVALENCED ENTRY 
          SA4    A3+B5             WORD 2 
          AX4    36 
          SX1    X4                WORD COUNT 
          BX6    X7+X3             ADD RELATIVE ADDRESS TO DIM ENTRY
          IX7    X7+X1             INCREMENT BLOCK LENGTH 
          SA6    A3                UPDATE WORD 1
  
*         SAVE WORD COUNT AND SYMORD IN LAT 
*         ** NEXT WORD MAY BE PLUGGED BY -ALA-. 
  
 ALA.P    LX1    36 
          SX2    B1-2 
          LX2    18-1 
          BX6    X1+X2             6/0,18/WC,18/SYMORD,18/0 
          SA6    B6+B7             SAVE ADDRESS IN LAT
          SB7    B7+B5             ADVANCE LENGTH 
          LE     B7,B4,ALA1        IF WE DIDN T RUN OUT OF SPACE
          EQ     PH1MO             PHASE 1 MEMORY OVERFLOW
  
 ALA.E    SX6    A1 
          SA6    ECSCOM            SET FLAG FOR ERROR MESSAGE 
          EQ     ALA1 
  
*         UPDATE BLOCK AND TABLE LENGTH, CHECK FOR LOCAL ECS VARIABLES
  
 ALAX     SA7    DATA..            UPDATE BLOCK LENGTH
          SX6    B7 
          SX3    A0                FWA OF SYMBOL TABLE
          SA6    L.LAT             SAVE LAT LENGTH
          SA6    S.LAT
  
          SA4    ECSCOM 
          ZR     X4,ALA            IF ALL ECS VARIABLES IN COMMON 
          IX2    X3-X4             2*ORD
          AX2    1
          RJ     PSYM              PREPARE THE SYMBOL 
          SB6    E.LECS            LEVEL 3 VARIABLES NOT IN COMMON
          SB7    ALA
          EQ     ERPRO
          TITLE              EQV - PROCESS EQUIVALENCE TABLES 
**        EQV - PROCESS EQUIVALENCE TABLES
* 
*         ENTRY:  
*                1) EQV TABLE FORMATED AS E1., E2.
* 
*                2) EVERY ENTRY IN THE EQV TBL HAS A ENTRY IN DIMTAB
*                AND IF IT IS IN COMMON THEN SO DO ALL OF THE 
*                OTHER MEMBERS OF THE BLOCK.
* 
*         THE ALGORITHM USED IS THAT OF GALLER AND FISHER 
*         IN THE MAY 1964 CACM ( PGS 301 - 303 )
* 
* 
*         NOTATIONS:  
*                EQV1,EQV2   WORD 1,2 OF EQV TABLE
*                GF1,GF2     WORD 1,2 OF GALLER-FISHER TABLE
*                SYMA,SYMB   WORD A,B OF SYMBOL TABLE 
*                DIM1,DIM2   WORD 1,2 OF DIMENSION TABLE
*                HI(I)       LENGTH ABOVE THE MEMBER
*                LO(I)       LENGTH BELOW THE ROOT
*                DIST(I)     SIGNED DISTANCE FROM ROOT TO MEMBER
*                P(I)        PARENT OF I IN THE TREE
*                FWA         FWA OF AN EQUIVALENCE GROUP
*                LWA         LWA OF AN EQUIVALENCE GROUP
*                SPAN        LENGTH OF AN EQUIVALENCE GROUP 
* 
*         THE G-F TABLE IS BUILT IN THE AREA OCCUPIED BY THE EQV TBL
*         SINCE AN INSPECTION OF THE ALGORITHM SHOWS THAT IT MUST 
*         BE SMALLER THAN THE NUMBER OF ELEMENTS PROCESSED FROM THE 
*         EQV TBL.
* 
  
  
 TEMPR    EQU    CBUF        TEMPORARIES
 TD       EQU    TEMPR+3     SAVED VALUE OF T0/D0 (SCAN1) 
          SPACE  4,20 
* 
*        UNPACK AND PACK MACROS PARIALLY SIMULATE THE PACK AND UNPACK 
*        OPERATION CODES.   EXCEPTIONS: NO SIGN EXTENSION WHEN USING
*        THE UNPACK MACRO. THE ENTIRE  EXPONENT FIELD IS USED STORE 
*        VALUES.
* 
*        UNPK    XN,BN,WXR,MR 
*        PACK    XN,BN,WXR,MR 
* 
*        XN - THE DESTINATION REGISTER AND MUST CONTAIN THE PACKED
*             FIELD OR THE COEFICIENT FIELD 
*        BN - THE EXPONENT FIELD , SELECTING B0 RESULTS IN THE
*             ELIMINATION OF ALL INSTUCTIONS ASSOCIATED WITH THE
*             BN AND WXR REGISTERS. 
*       WXR - SCRATCH REGISTER , IF BO IS SELECTED FOR THE B REGISTER 
*             THEN THIS REGISTER CAN BE SET TO VALUE SELECTED FOR 
*             MR REGISTER.
*        MR - MASK REGISTER 
* 
* 
 UNPK     MACRO  XN,BN,WXR,MR 
          M_MR   E1.GORL
          IFNE   BN,B0,1
          B_WXR  MR*XN
          B_XN   -MR*XN 
          IFNE   BN,B0,2
          L_WXR  E1.GORL
          S_BN   WXR
          ENDM
 PACK     MACRO  XN,BN,WXR,MR 
          IFNE   BN,B0,4
          M_MR   E1.SY2L
          S_WXR  BN 
          B_WXR  -MR*WXR
          L_WXR  E1.SY2L
          M_MR   E1.GORL
          B_XN   -MR*XN 
          IFNE   BN,B0,1
          B_XN   WXR+XN 
          ENDM
          TITLE    EQV - PRESCAN
**        PRESCAN - REFORMAT EQV1,EQV2 AS G1., G2. .
*                RA= ADDRESS RELATIVE TO BLOCK (0 IF LOCAL) 
  
  
 EQV      SUBR               ENTRY/EXIT 
          SA1    L.EQV
          SA2    O.EQV
          ZR     X1,EQV      IF NO EQUIVALENCE RELATIONS
          SA3    SYM1 
          SB3    B5+B5
          SB1    X2          EQA= FWA(EQVTAB) 
          SA4    O.DIM
          SA0    X3+
          SB6    X4-2 
  
*         FORMAT EQV TABLE WORD 1.
*                (B3)= 2
*                (B6)= O.DIM-2
*                (B1)= EQA
*                (A0)= SYM1 
  
 EQV020   SA2    B1          EQV1I= EQVTAB(EQA) 
          MX0    L.DIMP 
          MI     X2,EQV100   IF END OF EQV TABLE
          LX0    L.DIMP+P.DIMP
          MX4    E1.GORL-4
          BX1    X4*X2
          BX2    -X4*X2 
          LX1    E1.GORL-4
          SB2    X1 
          SB1    B1+B3       EQA= EQA+2 
          LX2    -E1.SY2P 
          SB4    X2          STINDB= SY2[EQV1I] 
          MX7    1
          LX2    G1.SYMP-1   SYMI= (STINDB-1) / 2 
          MX5    -L.RB
          SA1    A0-B4       SYMAI= SYMTAB(STINDB)
          SA4    A1-B5       SYMBI= SYMAI-1 
          LX1    -1-P.COM 
          BX7    X7*X1       COMI= COM[EQV1I] 
          LX7    1+G1.COMP
          BX3    X0*X4
          AX3    P.DIMP-1    DTIND= 2* DIMP[SYMBI]
          LX4    -P.RB
          BX6    -X5*X4      RBI= RB[SYMBI] 
          MX1    0           ASSUME DTIND MIGHT BE ZERO 
          ZR     X3,EQV021   IF ERROR CAUSES ZERO DTIND 
          SA1    B6+X3       DIM1I = DIMTAB [DTIND] 
          LX1    -D1.RAP
          SX1    X1          RAI= RA[DIM1I] 
 EQV021   BX1    X1+X2
          LX6    G1.RBP 
          BX6    X6+X1
          IX6    X6+X7
          SA6    A2          EQV1I= (COMI,SYMI,RBI,RAI) [G1.] 
  
*         FORMAT EQV TABLE WORD 2.
  
          MX0    -L.TYP 
          SA1    A1+B5       DIM2I= DIM1I+1 
          SA2    A2+B5       EQV2I= EQV1I+1 
          LX4    P.RB-P.TYP 
          BX4    -X0*X4 
          SX7    X4-T.DBL 
          SX3    B5 
          AX7    L.TYP
          BX4    -X7*X3      SDPF (= 0 IF SINGLE,= 1 IF DOUBLE) 
          MX0    D2.NDL 
          SB7    X4 
          LX0    D2.NDL+D2.NDP
          BX3    X0*X1       NDI= ND[DIM2I] 
          IFNE   D2.NDL,E2.NSL,2
          MX0    E2.NSL 
          LX0    E2.NSL+E2.NSP
          BX4    X0*X2       NSI= NS[EQV2I] 
          IX5    X3-X4
          ERRNZ  D2.NDP-E2.NSP
          MX0    D2.WCL 
          LX0    D2.WCL+D2.WCP
          MI     X5,EQ.E10   IF NDI  LT  NSI
          NZ     X3,EQV030   IF NDI  NE  0
          SX7    B7+B5       PI(DIMS)= 1+SDPF 
          LX7    D2.WCP 
          SA7    A1          WC[DIM2I]= PI(DIMS)
          LX7    Q2.PDP-D2.WCP
          PACK   X7,B2,X2,X0
          SA7    A2          EQV2I= [Q2.] 
          EQ     EQV020 
  
*         CALCULATE SUBSCRIPT.
*                (X1)= DIM2I
*                (X2)= EQV2I
  
 EQV030   BX7    X0*X1       PI(DIMS)= WC[DIM2I]
          LX4    -E2.NSP
          LX2    -E2.SAP     IND= SA[EQV2]
          SX5    X2-1 
          ZR     X4,EQ.E20   IF NSI  EQ  0
          SB4    X4 
          AX7    D2.WCP 
          SB4    B4-B5       NSI= NSI-1 
          ZR     B4,EQV040   IF NSI  EQ  0
          LX1    -D2.SAP
          SX0    X1          II= SA[DIM2] 
          LX2    E2.SAP-E2.SBP J= SB[EQV2]
          SX3    X2-1 
          IX4    X0*X3
          SB4    B4-B5       NSI= NSI-1 
          IX5    X4+X5       IND= IND+II*(J-1)
          ZR     B4,EQV040   IF NSI  EQ  0
          LX1    D2.SAP-D2.SBP
          SX1    X1          JJ= SB[DIM2] 
          IX0    X0*X1
          LX2    E2.SBP-E2.SCP  K=SC[EQV2]
          SX2    X2-1 
          IX4    X0*X2
          IX5    X4+X5       IND= IND+II*JJ*(K-1) 
 EQV040   LX5    B7,X5       ADJUST FOR DOUBLE PRECISION
          IX4    X5-X7
          LX5    Q2.SUBP
          LX7    Q2.PDP 
          BX7    X7+X5
          PL     X4,EQ.E30   IF IND  GT  PI(DIMS) 
          PACK   X7,B2,X2,X0
          SA7    A2          EQV2I= (GORI,PI(DIMS),IND) [Q2.] 
          EQ     EQV020 
          TITLE    EQV - SCAN1 - BUILD THE G-F TABLE
**        SCAN1 - BUILD THE G-F TABLE.
*         FORMAT G-F TABLE ENTRIES AS G1., G2. .
*         PASS 1 OF GALLER/FISHER EQUIVALENCE ALGORITHM.
  
  
 EQV100   SA1    O.EQV
          SB1    0           L.GF= 0
          SB2    0           EQIND= 0 
          SA0    X1 
          SB3    B5+B5
  
*                (A0)= O.EQV
*                (B1)= L.GF 
*                (B2)= EQIND
  
 EQV105   SA1    A0+B2       EQV1I= EQVTAB(EQIND) 
          BX5    X5-X5       ERFLAG= 0
          MI     X1,EQV200   IF END OF EQV TABLE
          MX0    G1.SYML
          SB7    -B3         T= -2 */INDEX TO G-F TABLE 
          SA2    A1+B5       EQV2I= EQV1I+1 
          LX0    G1.SYML+G1.SYMP
          UNPK   X2,B6,X7,X3
          SB2    B2+B3       EQIND= EQIND+2 
          BX7    X0*X1       SYMI= SYM[EQV1I] 
          LX2    -Q2.SUBP 
          SX6    X2          D= SUB[EQV2I]
  
*         SEARCH FOR MATCH OF SYMORD IN G-F TABLE PARTIALLY BUILT.
  
 EQV110   SB7    B7+B3       T= T+2 
          SA3    A0+B7       GF1T= G-FTAB(T)
          BX4    X0*X3       SYMT= SYM[GF1T]
          BX4    X4-X7
          GE     B7,B1,EQV130      IF T  GE  L.GF 
          NZ     X4,EQV110   IF SYMI  NE  SYMT
  
*         CURRENT ELEMENT IS IN THE G-F TABLE. CHAIN BACK UNTIL 
*         ITS ROOT IS FOUND, ADJUSTING D AS WE GO.
  
 EQV120   SA4    A3+B5       GF2T= GF1T+1 
          LX3    -G1.RAP
          UNPK   X4,B4,X1,X0
          EQ     B7,B4,EQV140      IF P(T)  EQ  T 
          SX3    X3          RAT= RA[GF1T]
          IX6    X3+X6       D= RAT + D 
          SA3    A0+B4       GF1T= G-FTAB(P(T)) 
          SB7    B4          T= P(T)
          EQ     EQV120 
  
*         CURRENT ELEMENT IS NOT YET IN THE G-F TABLE, CREATE AN
*         ENTRY FOR IT. 
*                (B7)= T
  
 EQV130   BX7    X1 
          SA7    A0+B7       GF1T= [G1.]
          LX2    Q2.SUBP-Q2.PDP 
          SX2    X2          HIT= PD[EQV2I], LOT= 0 
          SB1    B1+B3       L.GF=L.GF+2
          LX2    G2.HIP 
          BX7    X2 
          PACK   X7,B7,X1,X0
          SA7    A7+B5       GF2T= (T,HIT,LOT) [G2.]
  
*         CURRENT ELEMENT IS NOW IN THE G-F TABLE.
*         IF IT IS THE FIRST MEMBER OF A GROUP, REMEMBER IT AND RETURN
*         TO PROCESS THE NEXT ONE.
  
 EQV140   MX0    -G1.ADRL 
          NE     B6,B5,EQV150      IF NOT A NEW GROUP 
          PACK   X6,B7,X1,X2 TP= T; DO= D 
          SA6    TD          TD= (12/TO, 48/DO) 
          EQ     EQV105 
  
*         WHEN IT DOES NOT BEGIN A GROUP, LINK IT TO THE G-F TABLE. 
*                (B7)= T
*                (X6)= D
  
 EQV150   SA2    TD 
          UNPK   X2,B4,X3,X4
          SX2    X2 
          IX4    X2-X6       DIST= D0-D 
          LX0    G1.ADRP
          GT     B7,B4,EQV160      IF T  GT  T0 
          EQ     B7,B4,EQ.E40     IF CURRENT ALREADY LINKED TO THIS ROOT
  
*         IF CURRENT OCCURS BEFORE ITS ROOT, SWITCH THEM SO TABLE ALWAYS
*         LINK UPWARD.
  
          SB6    X4 
          SX4    -B6         DIST= -DIST
          SX7    B4          TEMP= T0 
          SB4    B7          T0= T
          SB7    X7          T= TEMP
          PACK   X6,B4,X3,X2
          SA6    TD          TD= (12/TO, 48/DO) 
  
*         BEFORE ADDING TO THE TREE, CHECK FOR CONSISTENCY AND ILLEGAL
*         EXTENSION OF COMMON BLOCK ORGIN.
  
 EQV160   SA3    A0+B7       GF1T= G-FTAB(T)
          SA2    A0+B4       GF1T0= G-FTAB(T0)
          BX1    -X0*X3      ADRT= ADR[GF1T]
          MX7    -G1.RBL
          LX3    -G1.SYMP 
          BX6    -X0*X2      ADRT0= ADR[GF1T0]
          NZ     X1,EQV170   IF ADRT  NE  0 
          NZ     X6,EQ.E60   IF ADRT0  NE  0
          EQ     EQV190 
  
*         CURRENT ELEMENT HAS AN ADDRESS, CHECK ITS ROOT. 
*         IF ITS ROOT DOES NOT HAVE AN ADDRESS, SET RB(T0)= RB(T),
*         RA(T0)= RA(T)-DIST. 
*                (X4)= DIST 
  
 EQV170   NZ     X6,EQ.E50   IF ADRT0  NE  0
          LX7    G1.RBP 
          BX6    -X7*X1      RBT= RB[GF1T]
          LX1    -G1.RAP
          SX1    X1          RAT= RA[GF1T]
          IX7    X1-X4       RAT0= RAT-DIST 
          BX6    X6+X2
          MI     X7,EQ.E70   IF RAT0  LT  0 
          SA1    A2+1        TO 
          SX1    X1 
          IX1    X7-X1
          MI     X1,EQ.E70   IF RA(TO) < 0
          LX7    G1.RAP 
          BX6    X7+X6
          SA6    A2          GF1T0= (RBT,RAT0) [G1.]
  
*         ADD ELEMENT TO PROPER TREE. 
*                (A2,A3)= GF1T, GF1T0 
*                (X4)= DIST 
*                (B4)= T0 
  
 EQV190   SA1    A3+B5       GF2T= GF1T+1 
          UNPK   X1,B0,X0,X0
          MX0    -G1.RAL
          BX6    -X0*X4 
          ERRNZ  18-G1.SYML 
          BX7    X1 
          PACK   X7,B4,X2,X0
          MX0    1
          SX2    X3          SYMT= SYM[GF1T]
          LX6    G1.RAP 
          LX3    G1.SYMP-1-G1.COMP
          BX3    X0*X3       COMI= COM[GF1T]
          LX2    G1.SYMP
          IX6    X6+X2
          LX3    1+G1.COMP
          BX6    X3+X6
          SA6    A1-B5       GF1T= (COMI,SYMT,0,DIST) [G1.] 
          SA7    A1          GF2T= (T0,HILOT) [G2.] 
  
*         ADJUST HI(T0), LO(T0).
*                HI(T0)= MAX (HI(T0), HI(T)+DIST) 
*                LO(T0)= MAX (LO(T0), LO(T)-DIST) 
  
          SA2    A2+B5       GF2T0= GF1T0+1 
          UNPK   X2,B0,X0,X0
          LX1    -G2.LOP
          SX0    X1          LOT= LO[GF2T]
          IX0    X0-X4       LOD= LOT-DIST
          LX2    -G2.LOP
          SX3    X2          LOT0= LO[GF2T0]
          LX1    G2.LOP-G2.HIP
          MX6    X0+X3       MAXLO= MAX( LOD,LOT0 ) 
          SX1    X1          HIT= HI[GF2T]
          LX2    G2.LOP-G2.HIP
          IX3    X1+X4       HID= HIT+DIST
          LX6    G2.LOP 
          SX2    X2          HIT0= HI[GF2T0]
          PACK   X6,B4,X7,X1
          MX7    X3+X2       MAXHI= MAX (HID,HIT0 ) 
          LX7    G2.HIP 
          BX7    X7+X6
          SA7    A2+         GF2T0= (T0,MAXHI,MAXLO) [G2.]
          ZR     X5,EQV105   IF ERFLAG  EQ  0 
          EQ     EQ.E75 
          TITLE    EQV - SCAN2 - COMMON-EQUIVALENCE OVERLAP SEARCH
**        SCAN2 - COMMON -EQUIVALENCE OVERLAP SEARCH. 
* 
*         FOR EACH EQUIVALENCE CLASS IN COMMON, EXTEND ITS RANGE TO 
*         INCLUDE MEMBERS OF COMMON BLOCK WHICH IT OVERLAPS.
*         ADD ADDITIONAL ENTRIES TO G-F TABLE FOR THESE MEMBERS AND 
*         UPDATE FWA AND LWA OF CLASS.
*                (B1)= LENGTH OF G-F TABLE
  
 EQV200   SX6    B1 
          SA6    L.EQV
          AX6    1
          ALLOC  EOT,X6      ALLOCATE SPACES FOR EOT
          SA1    L.EQV
          AX6    B5,X1
          SB3    B5+B5
          SA6    L.EOT
  
*         CREATE AN EOT ENTRY FOR EACH EQUIVALENCE CLASS, FORMAT AS EO. . 
*                FWA= RA(ROOT)-LO(ROOT) 
*                LWA= RA(ROOT)+HI(ROOT)-1 
  
          SA1    O.EQV
          SA5    O.EOT
          SB6    X1 
          SB7    B0          EOIND= 0 
          SA2    L.EQV
          SB4    -B3         EQIND= -2
          SB2    X2          L.GF= L.EQV
  
 EQV220   SB4    B4+B3       EQIND= EQIND+2 
          GE     B4,B2,EQV230      IF EQIND  GE  L.GF 
          SA1    B6+B4       GF1I= G-FTAB(EQIND)
          SA2    A1+B5       GF2I= GF1I+1 
          LX1    -G1.RAP
          UNPK   X2,B1,X3,X4
          LX2    -G2.LOP
          SX3    X1          RAI= RA[GF1I]
          SX4    X2          LOI= LO[GF2I]
          NE     B4,B1,EQV220      IF P[GF2I]  NE  EQIND  (NOT ROOT)
          LX1    G1.RAP-G1.RBP
          IX4    X3-X4       FWAI= RAI-LOI
          MX0    -EO.FWAL 
          BX4    -X0*X4 
          LX2    G2.LOP-G2.HIP
          BX6    -X0*X1      RBI= RB[GF1I]
          ERRNZ  G1.RBL-EO.FWAL 
          LX4    EO.FWAP
          SX2    X2          HII= HI[GF2I]
          MI     X2,EQ.E80   IF HII  GT  377777B
          IX3    X3+X2
          SX3    X3          LWAI= RAI+HII
          MI     X3,EQ.E80   IF LWAI  GT  377777B 
  
 EQV225   SX3    X3-1        LWAI= LWAI-1 
          LX6    EO.RBP 
          BX6    X6+X4
          SX2    B1          GFII= P[GF2I]
          LX3    EO.LWAP
          LX2    EO.GFIP
          BX2    X2+X3
          IX6    X6+X2
          SA6    X5+B7       EOT(EOIND)= (RBI,FWAI,LWAI,GFI) [EO.]
          SB7    B7+B5       EOIND= EOIND+1 
          EQ     EQV220 
  
*         SORT EOT IN ASCENDING ORDER.
*                (B7)= EOIND
*                (X5)= O.EOT
  
 EQV230   MX6    -1 
          SA6    A6+B5       ADD TERMINATOR WORD TO EOT 
          SX1    B7          LEN =EOIND 
          SB7    X5          FWA= O.EOT 
          RJ     SST
          SX7    B3-B7
          SA1    B7-B5       EOA= FWA-1 OF EOT
          SX7    X7+1 
          SA7    L.EOT       NEW L.EOT= LWA+1(EOT)-FWA(EOT)+1 
  
**        BEGIN COMMON EQUIVALENCE OVERLAP SEARCH.
*         FOR EACH EQUIVALENCE CLASS IN COMMON, SEARCH ITS COMMON 
*         BLOCK, ADDING MEMBERS TO THE CLASS WHEN THEY OVERLAP WITH 
*         THE SPAN OF THE CLASS.
*                (A1)= EOA
  
  
 EQV240   SA1    A1+B5       EOA= EOA+1, EOI= EOT(EOA)
          MI     X1,EQV300   IF END OF EOT
          MX0    -EO.RBL
          LX1    -EO.RBP
          BX7    -X0*X1      RBI= RB[EOI] 
          SA2    ORGTAB-1+X7 IND= PNT[ORGTAB(RBI)]
          ZR     X7,EQV240   IF RBI  EQ  0
          SA4    O.COM
          IX3    X2+X4
          SA2    X3+         CHI= COMTAB(IND) 
          LX2    -CH.NMP
  
 EQV245   SB7    X2 
          EQ     B7,B5,EQV290      IF NM[CHI]  EQ  1
          SB4    B5          J= 1      */COMMON MEMBER COUNT
  
*         COMMON MEMBER LOOP. 
*                (B4)= J
*                (B7)= NM[CHI]
*                (A1)= EOI
*                (A2)= CHI
  
 EQV255   GT     B4,B7,EQV290      IF J  GT  NM[CHI]
          SA1    A1          EOI
          SA4    A2+B4       CMI= COMTAB(IND+J) 
          MX0    -CM.WCL
          LX1    -EO.FWAP 
          SB4    B4+B5       J= J+1 
          SB1    X1          FWAC= FWA[EOI] 
          LX4    -CM.WCP
          BX3    -X0*X4      LENM= WC[CMI]
          LX1    EO.FWAP-EO.LWAP
          LX4    CM.WCP-CM.SYMP 
          SX5    X1          LWAC= LWA[EOI] 
          SX2    X4          SYMJ= SYM[CMI] 
          LX4    CM.SYMP-CM.RAP 
          SX4    X4          FWAM= RA[CMI]
          IX3    X3+X4
          SB1    -B1         FWAC= -FWAC
          SX3    X3-1        LWAM= FWAM +LENM-1 
          SX7    X3+B1
          IX6    X5-X4
          MI     X7,EQV255   IF LWAM  LT  FWAC
          SX7    -B1
          MI     X6,EQV255   IF LWAC  LT  FWAM
          MX6    X4-X7       FWAC= MIN(FWAM, FWAC)
          MX7    X3+X5       LWAC= MAX(LWAM, LWAC)
  
*         UPDATE FWA, LWA OF CLASS. 
*                (X7)= LWAC 
*                (X6)= FWAC 
  
          BX1    X0*X1
          ERRNZ  CM.WCL-EO.LWAL 
          PL     X6,EQV273   IF FWA OF CLASS NOT NEGATIVE 
          BX6    -X0*X6 
 EQV273   IX1    X1+X7
          LX1    EO.LWAP-EO.FWAP
          BX1    X0*X1
          ERRNZ  CM.WCL-EO.FWAL 
          IX6    X1+X6
          LX6    EO.FWAP
          SA6    A1          (FWA,LWA) [EOI]= (FWAC,LWAC) [EO.] 
  
*         CHECK IF THIS COMMON ELEMENT IS ALREADY IN THE G-F TABLE. 
*                (X2)= SYMJ 
*                (B6)= O.EQV
  
          SA5    L.EQV
          MX3    -EO.GFIL 
          LX2    G1.SYMP
          SB2    X5          LEQ= L.EQV 
          MX7    G1.SYML
          SB3    B5+B5
          LX7    G1.SYML+G1.SYMP
  
 EQV275   SB2    B2-B3       LEQ= LEQ-2 
          MI     B2,EQV280   IF END OF G-F TABLE
          SA5    B6+B2       GF1L= G-FTAB(LEQ]
          BX5    X7*X5
          IX5    X5-X2
          ZR     X5,EQV255   IF SYMJ  EQ  SYML
          EQ     EQV275 
  
*         NO MATCH IN G-F TABLE, CREATE AN ENTRY FOR IT.
*                (X6)= EOI
*                (A4)= CMI
  
 EQV280   SA4    A4          CMI
          LX6    -EO.GFIP 
          BX7    -X3*X6      GFIR= GFI[EOI] 
          SA5    B6+X7       GF1R= G-FTAB(GFIR) 
          LX4    -G1.RAP
          LX5    -G1.RAP
          SX4    X4          RAJ= RA[CMI] 
          SX5    X5          RAROOT= RA[GF1R] 
          MX3    1
          LX3    1+G1.COMP
          IX4    X4-X5       RAJ= RAJ-RAROOT
          SB2    X7 
          BX4    -X0*X4 
          ERRNZ  G1.RAL-CM.WCL
          LX4    G1.RAP 
          MX7    0
          BX6    X2+X4
          IX6    X6+X3
          PACK   X7,B2,X3,X4
          SA6    TEMPR       TEMPR(0)= (COM,SYMJ,0,RAJ) [G1.] 
          SA7    A6+1        TEMPR(1)= (GFIR,0) [G2.] 
  
*         BEFORE WE CALL ALLOC, STORE NECESSARY REGISTERS.
  
          SA3    O.EOT       SAVE (EOI-O.EOT, CHI-O.COM, J) 
          SA4    O.COM
          SX7    B4 
          SB2    X4 
          SX6    A2-B2
          SB1    X3 
          SA7    TEMPR+2     TEMPR(2)= J
          SA6    A7+B5       TEMPR(3)= CHI-O.COM
          SX7    A1-B1
          SA7    A6+1        TEMPR(4)= EOI-O.EOT
          SX5    2
          ALLOC  EQV,X5      ALLOCATE FOR GF1,GF2 
  
*         RESTORE REGISTERS AND SET NEW L.EQV.
  
          SA1    L.EQV
          SA2    TEMPR       NEW GF1= TEMPR(0)
          SA3    A2+B5       NEW GF2= TMEPR(1)
          SA4    O.EQV
          BX6    X2 
          BX7    X3 
          IX5    X1+X4       NEWIND= O.EQV+L.EQV
          SB6    X4 
          SA6    X5          GF1(NEWIND)= TEMPR(0)
          SA7    X5+B5       GF2(NEWIND)= TEMPR(1)
          SA3    A3+B5       RESTORE J,CHI,EOI
          SX6    X1+2 
          SA2    A3+B5
          SA4    A2+B5
          SB4    X3          J= TEMPR(2)
          SA6    A1          NEW L.EQV= L.EQV+2 
          SA5    O.EOT
          SA3    O.COM
          IX1    X4+X5       EOI= TEMPR(4)+ O.EOT 
          IX2    X2+X3       CHI= TMPER(3)+ O.COM 
          SA1    X1 
          SA2    X2 
          LX2    -CH.NMP
          SB7    X2 
          EQ     EQV255 
  
*         FINISHED WITH THIS BLOCK APPEARENCE, UPDATE BLOCK LENGTH
*         IF LWAC+1 .GT. BLOCK LENGTH.
*                (A2)= CHI
*                (A1)= EOI
  
 EQV290   SA2    A2 
          SA1    A1 
          LX2    -CH.LNKP 
          SB2    X2+         LINK= LNK[CHI] 
          LX1    -EO.LWAP 
          LX2    CH.LNKP-CH.LENP
          SX1    X1+1        LWAI= LWA[EOI]+1 
          MX6    -17
          BX3    -X6*X2      BLKLEN=LEN[CHI]
          IX7    X1-X3
          MI     X7,EQV295   IF LWAI  LT  BLKLEN
          IX7    X7+X2
          LX7    CH.LENP
          SA7    A2+         LEN[CHI]= LWAI 
 EQV295   ZR     B2,EQV240   IF LINK  EQ  0 
          SA2    A2+B2       CHI= COMTAB(IND+LINK)
          LX2    -CH.NMP
          EQ     EQV245 
          TITLE    EQV - SCAN3 - EQUIVALENCE CLASS OVERLAP SEARCH 
**        SCAN3 - EQUIVALENCE CLASS OVERLAP SEARCH. 
*         ENTRY: EOT FORMATED AS EO.
*         IF CLASS(N) AND CLASS(N+1) OF THE SAME COMMON BLOCK OVERLAP 
*         WITH EACH OTHER, MERGE THESE TWO CLASSES. 
*                (B6)= O.EQV
  
  
 EQV300   SA1    O.EOT
          SA2    L.EOT
          SB7    X1 
          SB4    X1          N= FWA OF EOT
          SX2    X2-3 
          SB2    0           I= 0  */INDEX TO EOT 
          MI     X2,EQV400   IF L.EOT  LT  3
  
*         OVERLAP SEARCH BEGINS.
  
 EQV310   SA1    B4          EOTN= EOT(N) 
          MX0    -EO.GFIL 
          MI     X1,EQV350   IF END OF EOT TABLE
          MX6    EO.RBL 
          LX6    EO.RBL+EO.RBP
          SA2    A1+B5       EOTN1= EOT(N+1)
          BX7    X6*X1
          BX6    X6*X2
          SB4    B4+B5       N= N+1 
          ZR     X7,EQV310   IF RB[EOTN]  EQ  0 
          IX7    X7-X6
          LX2    -EO.GFIP 
          NZ     X7,EQV310   IF RB[EOTN]  NE  RB[EOTN1] 
  
*         SAME RB, CHECK FOR OVERLAP. 
  
          BX4    -X0*X2      GFINSR= GFI[EOTN1] 
          LX2    EO.GFIP-EO.LWAP
          LX1    -EO.LWAP 
          SX5    X1          LWAN= LWA[EOTN]
          SX6    X2          LWAN1= LWA[EOTN1]
          LX2    EO.LWAP-EO.FWAP
          SX2    X2          FWAN1= FWA[EOTN1]
          IX7    X5-X2
          MI     X7,EQV310   IF LWAN  LT  FWAN1 
  
*         THERE IS OVERLAP. JOIN TWO CLASSES, UPDATING LWA AS NECESSARY.
*         COMPARE G-F INDEX OF EACH ROOT, MAKE THE SMALLER ONE TO BE THE
*         SURVIVING ROOT. 
*                (X3)= GFINSR, GFI OF NON-SURVIVING ROOT
  
          LX1    EO.LWAP-EO.GFIP
          MX2    X5+X6       LWAN= MAX(LWAN,LWAN1)
          BX3    -X0*X1      GFISR= GFI[EOTN] 
          BX6    X0*X1
          IX7    X3-X4
          MX0    -EO.LWAL 
          MI     X7,EQV330   IF GFISR  LT  GFINSR 
          BX7    X3          TEMP= GFISR
          SX3    X4          GFISR= GFINSR
          SX4    X7+         GFINSR= TEMP 
 EQV330   BX6    X6+X3
          LX6    EO.GFIP-EO.LWAP
          BX6    X0*X6
          SB1    X3          PSR= GFISR 
          IX6    X6+X2
          BX7    X7-X7
          SA3    B6+X3       GF1(GFISR) 
          LX6    EO.LWAP
          SA6    A2          EOTN1= (RBN,FWAN,LWAN,GFISR) [EO.] 
          SA7    A1          EOTN= 0
  
*         UPDATE G-F ENTRY OF NON-SURVIVING ROOT. 
*         ADJUST ITS RA AND MAKE IT POINT TO THE SURVIVING ROOT.
  
          LX3    -G1.RAP
          SA4    B6+X4       GF1(GFINSR)
          SX3    X3          RASR= RA[GF1(GFISR)] 
          LX4    -G1.RAP
          SX5    X4          RANSR= RA[GF1(GFINSR)] 
          ERRNZ  EO.LWAL-G1.RAL 
          IX7    X5-X3       RANSR= RANSR-RASR
          BX7    -X0*X7 
          SA5    A4+B5       GF2(GFINSR)
          UNPK   X5,B0,X1,X1
          BX4    X0*X4
          BX6    X5 
          PACK   X6,B1,X1,X0
          BX7    X4+X7
          LX7    G1.RAP 
          SA6    A5          P[GF2(GFINSR)]= PSR[G2.] 
          SA7    A4+         RA[GF1(GFINSR)]= RANSR[G1.]
          EQ     EQV310 
  
**        PUT EOT INDEX INTO GF2 OF EACH CLASS ROOT.
*         EOT INDEX UNIQUELY IDENTIFIES A CLASS.
*                (B6)= O.EQV
*                (B7)= O.EOT
*                (B2)= I (INDEX TO EOT) 
  
  
 EQV350   SA1    B7+B2       EOTI= EOT(I) 
          SB2    B2+B5       I= I+1 
          MI     X1,EQV400   IF END OF EOT TABLE
          ZR     X1,EQV350   IF EOTI  EQ  0 
          LX1    -EO.GFIP 
          SX7    B2-B5       EOTIND= I-1
          BX4    -X0*X1      GFII= GFI[EOTI]
          LX7    F2.EOIP
          SX4    X4+B5       GFII= GFII+1 
          SA2    B6+X4       GF2(GFII)
          BX7    X7+X2
          SA7    A2+         EOI[GF2(GFII)]= EOTIND 
          EQ     EQV350 
          TITLE    EQV - SCAN4 - G-F ADDRESS ASSIGNMENT 
**        SCAN4 - GALLER / FISHER ADDRESS ASSIGNMENT. 
* 
*         ADDRESS ASSIGNMENT OF LOCAL VARIABLES IS DONE RELATIVE TO 
*         THE CLASS ROOT.  IN SCAN5, THESE WILL BE RELOCATED TO THE 
*         DATA.. BLOCK. 
*         VARIABLES IN COMMON ARE ASSIGNED ADDRESSES RELATIVE TO THEIR
*         RESPECTIVE BLOCKS.
*         RB AND EOT INDEX OF THE ROOT ARE INHERITED BY THE MEMBERS.
*         BIAS OF EACH VARIABLE IS COMPUTED AS ITS RA - FWA OF THE
*         CLASS.
*                (B7)= O.EOT
*                (B6)= O.EQV
  
 EQV400   SA1    L.EQV
          SB3    B5+B5
          SA0    B6 
          SB1    X1          L.GF= L.EQV
          SB4    -B3         I= -2     */INDEX TO  G-F TABLE
          SB2    0           N.LR= 0   */NO. LOCAL ROOTS
  
 EQV410   SB4    B4+B3       I= I+2 
          GE     B4,B1,EQV500      IF I  GE  L.GF 
          SA1    A0+B4       GF1I= G-FTAB(I)
          SA2    A1+B5       GF2I= G-FTAB(I+1)
          MX0    -G1.RAL
          LX1    -G1.RAP
          UNPK   X2,B6,X3,X7   PI=P[GF2I] 
          SX3    X1          RAI= RA[GF1I]
          NE     B4,B6,EQV420      IF I  NE  PI 
  
*         CLASS ROOT. 
*         COMPUTE BIAS = RA-FWA, FORMAT GF2 AS F2. .
*         UPDATE N.LR IF IT IS LOCAL. 
  
          MX7    -F2.EOIL 
          LX2    -F2.EOIP 
          BX6    -X7*X2      EOTIND= EOI[GF2I]
          LX1    G1.RAP-G1.RBP
          SA5    B7+X6       EOTI= EOT(EOTIND)
          LX5    -EO.FWAP 
          ERRNZ  EO.FWAL-G1.RAL 
          BX5    -X0*X5      FWAI= FWA[EOTI]
          LX6    F2.EOIP
          SX4    X5          SIGN EXTEND FWAI 
          IX3    X3-X4       BIASI= RAI- FWAI 
          LX5    F2.FWAP
          BX6    X6+X5
          BX3    -X0*X3       MASK TO 18 BITS IN CASE NEGATIVE BIAS 
          ERRNZ  G1.RBL-G1.RAL
          BX7    -X0*X1      RBI= RB[GF1I]
          LX3    F2.BIAP
          BX6    X6+X3
          SA6    A2          GF2I= (EOTIND,BIASI,FWAI) [F2.]
          NZ     X7,EQV410   IF RBI  NE  0
          SB2    B2+B5       N.LR= N.LR+1 
          EQ     EQV410 
  
*         NON ROOT MEMBERS. 
*         COMPUTE RA(I)= RA(I) - RA(P(I)), BIAS(I)= RA(I) - FWA(P(I)).
*         SET RB(I)= RB(P(I)), FWA(I)= FWA(P(I)). 
*                (B6)= PI 
*                (X3)= RAI
  
 EQV420   SA4    A0+B6       GF1PI= G-FTAB(PI)
          SA2    A4+B5       GF2PI= G-FTAB(PI+1)
          LX1    -G1.RAP
          BX7    X0*X1
          LX4    -G1.RAP
          SX6    X4          RAP= RA[GF1PI] 
          IX3    X3+X6       RAI= RAI+ RAP
          LX4    G1.RAP-G1.RBP
          BX6    -X0*X3 
          IX7    X7+X6
          LX7    G1.RAP-G1.RBP
          ERRNZ  G1.RBL-G1.RAL
          BX5    -X0*X4      RBP= RB[GF1PI] 
          BX7    X7+X5
          LX7    G1.RBP 
          SA7    A1          GF1I= (RBP,RAI) [G1.]
          ERRNZ  G1.RAL-F2.BIAL 
          LX0    F2.BIAP-G1.RAP 
          BX6    X0*X2       EOFWA= (EOI,FWA) [GF2PI] 
          LX2    -F2.FWAP 
          SX2    X2          FWAI= FWA[GF2PI] 
          IX3    X3-X2       BIASI= RAI-FWAI
          MX0    -F2.BIAL 
          BX3    -X0*X3       MASK TO 18 BITS IN CASE NEGATIVE BIAS 
          LX3    F2.BIAP
          BX6    X6+X3
          SA6    A1+B5       GF2I= (EOFWA,BIASI) [F2.]
          EQ     EQV410 
          TITLE    EQV - SCAN5 - FORMAT ECT , DIM2 ENTRIES
**        SCAN5 - FORMAT ECT, DIM2 ENTRIES. 
*         CREATE AND SORT ECT, FIND ULTIMATE BASE FOR EACH CLASS. 
*         FORMAT WORD 1 OF DIM TABLE, AND ADD BITS TO SYMBOL TABLE
*         WORDS. A LOCAL VARIABLE NOW WILL HAVE RA RELATIVE TO THE BLOCK
*         DATA.. .
*                (B2)= N.LR 
  
  
*         ALLOCATE SPACES FOR ECT AND LAT.
  
 EQV500   SX6    B2 
          SA6    TEMPR
          ALLOC  LAT,X6      ALLOCATE SPACES FOR LAT
          SA1    L.EQV
          SA2    TEMPR
          AX1    1
          BX7    X2 
          SX6    X1+B5       EXTRA WORD FOR TERMINATOR
          SA7    L.LAT       L.LAT= N.LR
          ALLOC  ECT,X6      ALLOCATE SPACES FOR ECT
          SB3    B5+B5
          MX7    1
  
**        FORM TEMPORARY ECT ENTRIES. 
* 
*         THE ULTIMATE BASE OF A CLASS HAS BIAS OF 0, SINCE BIAS WAS
*         COMPUTED AS RA - FWA IN SCAN4.  SORTING OF THE G-F TABLE BY 
*         EOI AND BIAS WILL PROVIDE US WITH SEPARATED CLASSES WITH
*         BASE MEMBER BEING THE FIRST MEMBER OF THE CLASS.
*         TEMPORARY ECT ENTRIES ARE FORMATED AS TE. . 
  
  
          SA1    O.ECT
          SA2    O.EQV
          SA3    L.EQV
          SA4    SYM1 
          SB7    X1 
          SB6    X2 
          SB1    X3          L.GF= L.EQV
          SB4    -B3         GFIND= -2
          SA0    X4 
          MX0    -F2.EOIL 
          LX7    1+TE.CBBP   CBBI= 1
  
 EQV510   SB4    B4+B3       GFIND= GFIND+2 
          GE     B4,B1,EQV520      IF GFIND  GE  L.GF 
          SX3    B6+B4       GFADI= G-F TAB(GFIND)
          SX2    B4 
          SA4    X3          GF1I= G-F TAB(GFADI) 
          SA1    A4+B5       GF2I= GF1I+1 
          LX1    -F2.EOIP 
          BX6    -X0*X1      EOII= EOI[GF2I]
          LX3    TE.GFAP
          LX6    TE.EOIP
          BX6    X6+X3
          LX1    F2.EOIP-F2.BIAP
          SX1    X1          BIAI= BIA[GF2I]
          ERRNZ  18-F2.BIAP 
          BX6    X6+X7
          LX1    TE.BIAP
          IX6    X6+X1
          LX4    -1-G1.COMP 
          NZ     X1,EQV515   IF BIAI  NE  0 
          PL     X4,EQV515   IF COM[GF1I]  NE  1
          BX6    -X7*X6      CBBI= 0
 EQV515   AX2    1           ECII= GFIND/2
          SA6    X2+B7       ECT[ECII]= (CBBI,EOII,BIAI,GFADI) [TE.]
          EQ     EQV510 
  
*         SORT TEMPORARY ECT ENTRIES. 
*                X2= L.ECT-1
*                B7= O.ECT
  
 EQV520   SX6    0
          SX1    X2+B5
          SA6    A6+B5       STORE TERMINATOR WORD IN ECT 
          RJ     SST
          SX7    B3-B7
          SX7    X7+B5
          SA7    L.ECT       L.ECT= LWA+1(ECT)-FWA(ECT)+1 
  
**        FORM ECT ENTRIES AS EC., AND  DIM1 ENTRIES AS D1. . 
*         ADD EQU,COM,DEF BITS TO SYMA, RB TO SYMB. 
*         THE FIRST MEMBER OF A CLASS IS THE BASE, SINCE ECT TABLE
*         HAS BEEN SORTED ACCORDING TO BIAS.
*         A DIFFERENT EOT INDEX INDICATE THE BEGINNING OF NEXT CLASS. 
*                           (A0)= SYM1
  
  
          SA3    O.DIM
          SA1    B7-B5      ECA= FWA(ECT)-1 
          SB2    B0         MCNT= 0         */CLASS MEMBER COUNT
          SB1    -B5        EOIND= -1 
          SB6    X3-2 
          SB7    B0         LATIND= 0 
  
*         NEXT TEMPORARY ECT ENTRY. 
*                (B1)= EOIND
  
 EQV530   SA1    A1+B5       ECAD= ECAD+1, ECI= ECT(ECAD) 
          ZR     X1,EQV580   IF END OF ECT TABLE
          MX0    -TE.EOIL 
          LX1    -TE.GFAP 
          SB4    X1          GFAI= GFA[ECI] 
          LX1    TE.GFAP-TE.EOIP
          BX3    -X0*X1      EOII= EOI[ECI] 
          SX2    B1 
          LX1    TE.EOIP-TE.BIAP
          IX7    X2-X3
          SX4    X1          BIASI= BIA[ECI]
          SB1    X3          EOIND= EOII
          ZR     X7,EQV560   IF EOIND  EQ  EOII 
  
*         CLASS BASE. 
*         UPDATE MCNT FOR THE PREVIOUS CLASS. 
*                (B2)= MCNT 
  
          MI     X2,EQV535   IF FIRST BASE MEMBER 
          SX6    B2 
          SB2    B2+B5       ECBIND= MCNT+1 
          LX6    EC.NMP 
          SA2    A1-B2       ECB= ECT(ECAD-ECBIND)
          BX6    X2+X6
          SA6    A2          NM[ECB]= MCNT
          SB2    B0          MCNT= 0
  
*         COMPUTE SPAN OF CLASS, UPDATE ECT, DIM1 ENTRIES.
  
 EQV535   SA2    O.EOT
          MX0    -EO.RBL
          SA3    B4          GF1I= G-FTAB(GFAI) 
          SA2    X2+B1       EOI= EOT(EOIND)
          LX3    -G1.SYMP+1 
          LX2    -EO.RBP
          SX5    X3 
          SB3    X3+B5       STINDB= 2 * SYM[GF1I] +1 
          BX7    -X0*X2      RBI= RB[EOI] 
          LX5    EC.SYMP-1   SYMI= SYM[GF1I]
          LX2    EO.RBP-EO.LWAP 
          SX4    X2+B5       LWAI= LWA[EOI] + 1 
          MX3    L.DIMP 
          LX2    EO.LWAP-EO.FWAP
          SX2    X2          FWAI= FWA[EOI] 
          IX4    X4-X2       SPANI= LWAI-FWAI 
          LX4    EC.SPNP
          BX6    X4+X5
          LX3    L.DIMP+P.DIMP
          SA2    A0-B3       SYMBI= SYMTAB(STINDB)
          LX4    -EC.SPNP 
          MX1    1
          BX2    X3*X2
          AX2    P.DIMP-1    DIMPI= 2 * DIMP[SYMBI] 
          LX5    D1.SYMP-EC.SYMP   D1SKEL= SYMI[D1.]
          NZ     X7,EQV550   IF RBI  NE  0
  
*         LOCAL BASE. 
*         UPDATE LOCAL BLOCK LENGTH DATA.. , FORMAT DIM1 SKELETON FOR 
*         NON-BASE MEMBERS. 
*                (X2)= DIMPI
  
          SA3    O.LAT
          LX1    1+D1.LOCP
          SA6    A1          ECI= (SPANI,SYMI,0) [EC.]
          SA6    X3+B7       LAT(LATIND)= ECI 
          BX5    X1+X5
          SB7    B7+B5       LATIND= LATIND+1 
          SA3    DATA.. 
          IX6    X4+X3
          LX3    D1.RAP 
          SA6    A3          NEW DATA..= DATA..+ SPANI
          IX5    X5+X3       D1SKEL= (1,SYMI,0,DATA..) [D1.]
          LX4    D1.SPNP
          BX7    X5+X4
          SA7    B6+X2       DIMTAB(DIMPI)= (1,SYMI,SPANI,DATA..) [D1.] 
          EQ     EQV530 
  
*         COMMON BASE.
*         FORM DIM1 SKELETON FOR COMMON CLASS MEMBERS, AND SET
*         (DEF,COM) BITS IN SYMA . BASES THAT WERE NOT IN COMMON
*         BEFORE NOW GET RB IN THEIR SYMB.
*                (X2)= DIMPI
*                (X7)= RBI
  
 EQV550   SA4    B4          GF1I= G-FTAB(GFAI) 
          SA3    A2+B5       SYMAI= SYMTAB(STINDB-1)
          LX1    1+EC.CBP 
          LX7    P.RB 
          BX6    X6+X1
          LX4    -G1.RAP
          SA6    A1          ECI= (CB,SPANI,SYMI,0) [EC.] 
          SX1    V.COM+V.DEF
          MX0    -L.RB
          LX0    P.RB 
          BX6    X3+X1
          SA6    A3          SYMAI= (COM,DEF) [SYMA]
          SX4    X4          RAI= RA[GF1I]
          LX4    D1.RAP 
          SA3    A3-B5       SYMBI= SYMTAB(STINDB)
          BX6    X5+X4
          BX3    X0*X3
          IX7    X3+X7
          SA6    B6+X2       DIMTAB(DIMPI)= (0,SYMI,0,RAI) [D1.]
          SA7    A3+         RB[SYMBI]= RBI 
          EQ     EQV530 
  
*         CLASS MEMBERS.
*                (X4)= BIASI
*                (X5)= D1SKEL 
*                (B4)= GFAI 
  
 EQV560   SA3    B4          GF1I= G-FTAB(GFA)
          LX4    D1.RAP 
          IX6    X4+X5       RAI= BIAI+RA[D1SKEL] 
          LX3    -G1.RBP
          SX2    X3          RBI= RB[GF1I]
          LX3    G1.RBP-G1.SYMP+1 
          SX0    X3          STINDA= 2 * SYM[GF1I]
          SX7    V.EQU       SYMABTS= EQU[SYMA] 
          LX4    EC.BIAP-D1.RAP 
          MX1    -L.RB
          ZR     X2,EQV570   IF RBI  EQ  0
          SX7    X7+V.COM+V.DEF     SYMABTS= (EQU,COM,DEF) [SYMA] 
          SA3    A3+B5       GF2I 
          LX3    -F2.FWAP 
          SX3    X3          FWA1 = FWA[GF2I] 
          LX3    D1.RAP 
          IX6    X6+X3       RAI = RAI + FWAI 
 EQV570   SB3    X0 
          LX0    EC.SYMP-1
          BX3    X0+X4
          LX4    D1.BIAP- EC.BIAP 
          BX6    X6+X4
          MX0    L.DIMP 
          LX0    L.DIMP+P.DIMP
          SA4    A0-B3       SYMAI= SYMTAB(STINDA)
          LX2    P.RB 
          BX7    X4+X7
          SA4    A4-B5       SYMBI= SYMTAB(STINDA+1)
          LX1    P.RB 
          BX0    X0*X4       DIMPI= DIMP[SYMBI] 
          BX4    X1*X4
          SA7    A4+B5       SYMAI= SYMABTS[SYMA] 
          AX0    P.DIMP-1    DIMPI= 2 * DIMPI 
          BX7    X4+X2
          SA6    X0+B6       DIMTAB(DIMPI)= [D1.] 
          SA7    A4          RB[SYMBI]= RBI 
          SA2    A6+B5       DIM2I= DIMTAB(DIMPI+1) 
          LX2    -D2.WCP
          SX6    X2 
          LX6    EC.WCP 
          BX6    X6+X3
          SA6    A1          ECTI= (WCI,SYMI,BIASI) [EC.] 
          SB2    B2+B5       MCNT= MCNT+1 
          EQ     EQV530 
  
*         UPDATE MCNT FOR THE LAST CLASS. 
*                (B2)= MCNT 
  
 EQV580   SX6    B2 
          SB2    B2+B5
          SA2    A1-B2       ECB= ECT(ECA-MCNT+1) 
          BX6    X2+X6
          SA6    A2          NM[ECB]= MCNT
  
**        PREPARE TO EXIT EQUIVALENCE PROCESSING. 
*         MOVE ECT TO EQV TABLE AND CLEAR L.EOT AND L.ECT.
*         A FINAL RETURN JUMP TO SUBROUTINE *CLE* IS MADE TO
*         RESOLVE LEVEL-EQUIVALENCE CONFLICTS AND TO PROPAGATE
*         LEVEL/LCM BITS THRU EQUIVALENCE CLASSES.
  
          BX7    X7-X7
          SA5    O.ECT
          SA4    O.EQV
          SA7    L.EOT       NEW L.EOT= 0 
          SX0    X4          EQIND= FWA(EQVTAB) 
          SA5    X5          ECA= FWA(ECT)
          SB2    0           ECIND= 0 
  
*         MOVE ECT TO EQV TABLE.
  
 EQV585   SA5    A5+B2       ECA= ECA+ECIND   ECI= ECT(ECA) 
          ZR     X5,EQV590   IF END OF ECT
          LX5    -EC.NMP
          SB2    X5+B5       ECIND= NM[ECI] + 1 
          EQ     B2,B5,EQ.E90      IF ECIND  EQ  1
          MOVE   B2,A5,X0 
          SX0    X0+B2       EQIND= EQIND+ ECIND
          EQ     EQV585 
  
 EQV590   SA1    O.EQV
          SA2    LEVEL
          IX6    X0-X1
          SA6    L.EQV       NEW L.EQV= EQIND - FWA(EQV)
          ZR     X2,EQV595   IF NO LEVEL STATEMENTS 
          RJ     CLE         COORDINATE LEVEL INFO
          RJ     CCL               COORDINATE COMMON LEVEL INFO 
  
 EQV595   SX7    0
          SA7    L.ECT       L.ECT= 0 
          EQ     EXIT.
          TITLE    EQV - ERROR EXITS
**        CHECK/PROCESS EQUIVALENCE ERRORS. 
  
  
**        PRESCAN ERRORS. 
  
 EQ.E10   SB6    E.S>D
          BX7    X0*X1       PI(DIMS)= WC[DIM2I]
          NZ     X7,EQ.E32   IF PI(DIMS)  NE  0 
          SX7    X6+B5       PI(DIMS)= 1+ SDPF, (IND= 0)
          LX7    D2.WCP 
          SA7    A1          WC[DIM2I]= PI(DIMS)
          LX7    Q2.PDP-D2.WCP
          EQ     EQ.E32 
  
*                (X7)= PI(DIMS) 
  
 EQ.E20   SB6    E.NOS
          LX7    Q2.PDP-D2.WCP     (IND= 0) 
          EQ     EQ.E32 
  
*                (X7)= (PI(DIMS),IND) [Q2.] 
  
 EQ.E30   SB6    E.DRE
 EQ.E32   SA1    A2-B5
          SA3    O.EQV
          SX6    B1 
          PACK   X7,B2,X2,X4
          SA7    A2          EQV2I= (GORI,PI(DIMS),IND) [Q2.] 
          IX6    X6-X3
          LX1    -G1.SYMP 
          SX2    X1          SYMORD= SYM[EQV1I] 
          SA6    TEMPR       TEMPR= EQA-O.EQV 
          RJ     PSYM 
          SB1    E.S>D
          NE     B1,B6,EQ.E34      IF  NOT  E.S>D 
          POSTER SEV=FE,NR=**,RETURN=EQ.E38 
  
 EQ.E34   SB1    E.NOS
          NE     B1,B6,EQ.E36      IF  NOT  E.NOS 
          POSTER SEV=ANSI,NR=**,RETURN=EQ.E38 
  
 EQ.E36   POSTER SEV=INF,NR=**
 EQ.E38   SA1    TEMPR
          SA2    O.DIM
          SA3    O.EQV
          SB6    X2-2 
          IX1    X3+X1
          SB1    X1          EQA= O.EQV+TEMPR 
          EQ     EQV020 
  
**        SCAN1 ERRORS. 
*         CONTRADICTORY/ REDUNDANT EQUIVALENCE ERRORS.
  
 EQ.E40   SA3    A0+B7
          SB6    E.RER
          LX3    -G1.SYMP 
          SX2    X3+         SYMORD= SYM[GF1T]
          ZR     X4,EQ.E76   IF DIST  NE  0 (REDUNDANCY)
  
          SB6    E.CER       (CONTRADICTION)
          EQ     EQ.E76 
  
 EQ.E50   IX0    X1-X6
          SX7    E.RER
          LX0    -G1.ADRP 
          SX5    X3          ERFLAG= SYM[GF1T]
          SA7    TEMPR
          IX0    X0-X4       DIF= (RA[GF1T] - RA[GF1T0]) - DIST 
          SX6    E.CER
          ZR     X0,EQV190   IF DIF  EQ  0 (REDUNDANT)
          SA6    TEMPR       (REDUNDANCY) 
          EQ     EQV190 
  
*         ILLEGAL EXTENSION OF COMMON BLOCK ORGIN 
* 
*         EXTENSION BY MEMBER.
  
 EQ.E60   LX2    -G1.RAP
          SX0    X2 
          IX7    X0+X4
          PL     X7,EQV190   IF RAT0+ DIST  GT  0 
          SX6    E.CBE
          BX4    -X0         DIST= -RAT0
          SX5    X3          ERFLAG= SYM[GF1T]
          SA6    TEMPR
          EQ     EQV190 
  
*         EXTENSION BY ROOT.
  
 EQ.E70   SA6    A2          GF1T0= [G1.] 
          SX4    X1          SET DIST= RAT
          SX7    E.CBE
          LX2    -G1.SYMP 
          SX5    X2          ERFLAG= SYM[GF1T0] 
          SA7    TEMPR
          EQ     EQV190 
  
*         POST ERRORS FOR SCAN1.
  
 EQ.E75   SA1    TEMPR       ERR NO.
          SX2    X5          SYMORD= ERFLAG 
          SB6    X1 
 EQ.E76   SX6    B1          SAVE L.GF, EQIND 
          SX7    B2 
          SA6    TEMPR+1
          SA7    A6+B5
          RJ     PSYM 
          SB1    E.RER
          NE     B6,B1,EQ.E77      IF  NOT  E.RER 
          POSTER SEV=INF,NR=**,RETURN=EQ.E79
  
 EQ.E77   POSTER SEV=FE,NR=** 
 EQ.E79   SA1    TEMPR+1     RESTORE L.GF,EQIND,O.EQV 
          SA3    O.EQV
          SA2    A1+B5
          SB1    X1 
          SB2    X2 
          SA0    X3 
          EQ     EQV105 
  
**        SCAN2 ERRORS. 
*         EQUIVALENCED COMMON BLOCK LENGTH EXCEEDS 377777B
  
 EQ.E80   SA2    O.COM
          SX3    377777B     LWAI= 377777B
          ZR     X6,EQV225   IF RBI  EQ  0
          SA3    ORGTAB-1+X6 IND= PT[ORGTAB(RBI)] 
          MX7    1
          LX7    1+CH.EVLP
          IX2    X3+X2
          SA2    X2          CH= COMTAB(IND)
          BX7    X2+X7
          SA7    A2          EVL[CH]= 1 
          SX3    377777B     LWA= 377777B 
          EQ     EQV225 
  
**        SCAN5 ERRORS. 
*         ONLY ONE NAME IN EQUIVALENCE GROUP. 
*                (A5,X5)= ECI 
*                (X0)= EQIND
  
 EQ.E90   SA1    O.ECT
          SA3    O.EQV
          SB2    X1 
          LX5    EC.NMP-EC.SYMP 
          SX6    A5-B2
          IX7    X0-X3
          SX2    X5          SYMORD= SYM[ECTI]
          SA6    TEMPR       TEMPR(0)= ECI-O.ECT
          SA7    A6+B5       TEMPR(1)= EQIND-O.EQV
          RJ     PSYM 
          POSTER NR=E.E1N,SEV=FE,FMT=DPC,TXT=X3 
          SA1    O.ECT       RESTORE ECA,EQIND
          SA2    TEMPR
          IX5    X1+X2       ECI= TEMPR(0) - O.ECT
          SA3    O.EQV
          SA4    A2+B5
          IX0    X3+X4       EQIND= TEMPR(1) - O.EQV
          SA5    X5 
          SB2    B5          ECA= 1 
          EQ     EQV585 
          TITLE  EQV - SST - SHELL SORT 
***       SST - SHELL SORT TABLE. 
*         E. J. MUNDSTOCK.  70/10/07. 
*         UNIVERSITY OF MINNESOTA.
* 
*         SST SORTS A TABLE USING A SHELL SORTING TECHNIQUE.
*         THE TABLE IS SORTED IN PLACE INTO ASCENDING ORDER.
*         ALL ELEMENTS SHOULD BE OF THE SAME SIGN.
* 
*         ORIGIN OF TECHNIQUE IS CACM VOL 6 NUMBER 5  MAY 1963, P209. 
*         FIRST CODED BY R. HOTCHKISS IN *SORT1*. 
*         REVISED BY L. A. LIDDIARD.
* 
*         ENTRY  (B5) = 1 
*                (B7) = FWA OF TABLE TO BE SORTED 
*                (X1) = NUMBER OF ELEMENTS IN ARRAY 
* 
*         EXIT   TABLE SORTED.
*                (B3) = LWA+1 OF TABLE
*                (B7) = FWA OF TABLE
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4, 5.
*                A - 1, 2, 6, 7.
* 
*         CALLS NONE. 
  
  
 SST1     SA7    B1-B4       T(J+K) = S 
          SB2    B2+B5       I = I+1
          EQ     B2,B3,SST4  IF END OF TABLE
 SST2     SA2    B2          S = T(I) 
          NO
          SB1    B2+B4       J = I-K
          BX7    X2 
 SST3     SA1    B1          T(J) 
          IX3    X2-X1       COMPARE S AND T(J) 
          PL     X3,SST1     IF ELEMENTS IN ORDER 
          BX6    X1          T(J+K) = T(J)
          SB1    B1+B4       J = J-K
          SA6    A1-B4
          GE     B1,B7,SST3  IF J " FIRST 
          EQ     SST1 
  
 SST4     AX4    1           K = K/2
          NO
          SB4    X4          (B4) = -K
          SB2    B7-B4       I = FIRST+K
          NZ     X4,SST2     IF K " 0 
  
 SST      PS                 ENTRY/EXIT 
          MX4    12          K = 2**(ENTIER(LOG2(COUNT)+1)
          SB3    B7+X1       (B3) = LAST+1
          NX6,B2 X1 
          AX4    X4,B2
          EQ     SST4        ENTER SORT LOOP
          TITLE    EQV - CLE - COORDINATE LEVEL EQUIVALENCE INFORMATION 
**        CLE - COORDINATE LEVEL EQUIVALENCE INFORMATION
*         ENTRY: ECT ENTRIES FORMATED AS EC. .
*                (A0)= SYM1 
* 
**        PHASE A - CHECK LEVEL SPECIFICATION WITHIN EACH EQUIVALENCE 
*                CLASS.  MAKE SURE THE BASE MEMBER IS GIVEN A LEVEL 
*                SPECIFICATION BELONGIN TO THE FIRST LEVELED MEMBER.
  
 CLE      SUBR               ENTRY/EXIT 
          SA1    O.ECT
          SA5    O.COM
          SA1    X1-1        ECIND= FWA(ECT)-1
          MX0    -L.LVL-1 
          LX0    P.LCM
  
*         CLASS BASE. 
  
 CLE10    SA1    A1+B5       ECTB= ECT(ECIND) 
          ZR     X1,CLE50    IF END OF ECT TABLE
          SB6    B0          ERFLAG= 0  */LOCAL LEVEL ERROR FLAG
          LX1    -EC.NMP
          SB2    X1          NMB= NM[ECTB]
          MX4    -L.RB
          LX1    EC.NMP-EC.SYMP+1 
          SB1    X1+B5       STIND= SYM[ECTB]+1 
          SA2    A0-B1       SYMBB= SYMTAB(STIND) 
          BX6    -X0*X2      LEVB= (LVL,LCM) [SYMBB]
          AX2    P.RB 
          SB4    B0          MIND= 0    */MEMBER INDEX
          BX2    -X4*X2      RBB= RB[SYMBB] 
          SX3    -B5         IND= -1
          ZR     X2,CLE20    IF RBB  EQ  0
          SA3    ORGTAB-1+X2       IND= PNT[ORGTAB(RBB)]
  
*         CLASS MEMBER. 
*                (X3)= IND (= -1 IF LOCAL)
*                (A1)= ECTB 
*                (X6)= LEVB 
*                (X5)= O.COM
  
 CLE20    SB4    B4+B5       MIND= MIND+1 
          GT     B4,B2,CLE45       IF MIND  GT  NMB 
          SA1    A1+B5       ECTM= ECT(ECIND+1) 
          LX1    -EC.SYMP+1 
          SB3    X1+B5       STINDM= 2* SYM[ECTM]+1 
          SA2    A0-B3       SYMBM= SYMTAB(STINDM)
          BX4    -X0*X2      LEVM= (LVL,LCM) [SYMBM]
          ZR     X4,CLE20    IF LEVM  EQ  0 
          ZR     X6,CLE30    IF LEVB  EQ  0 
  
*         BASE LEVELED, CHECK LEVEL CONFLICT OF MEMBER. 
  
          BX7    X6-X4
          ZR     X7,CLE20    IF LEVB  EQ  LEVM
          MI     X3,CLE25    IF IND  LT  0 (LOCAL)
          IX2    X5+X3
          SA2    X2          CH= COMTAB(IND)
          MX7    1
          LX7    1+CH.LEEP
          IX7    X2+X7
          SA7    A2          LEE[CH]= 1 
          EQ     CLE20
  
 CLE25    SB6    B3+         ERFLAG= STINDM 
          EQ     CLE20
  
*         BASE NOT LEVELD,  SET LEVB= LEVM
  
 CLE30    SA2    A0-B1       SYMBB= SYMTAB(STINDB)
          BX6    X4          LEVB= LEVM 
          IX7    X2+X4
          SA7    A2          (LVL,LCM)[SYMBB]= LEVM 
          MI     X3,CLE20    IF IND  LT  0
          MX7    1
          IX2    X5+X3
          SA2    X2          CH= COMTAB(IND)
          LX7    1+CH.NALP
          BX7    X2+X7
          SA7    A2          NAL[CH]= 1 
          EQ     CLE20
  
 CLE45    ZR     B6,CLE10    IF ERFLAG  EQ  0 
          EQ     CLE.E
  
**        PHASE B- CHECK LEVEL SPECIFICATION WITHIN EACH EQUIVALENCE
*         CLASS.  MAKE SURE ALL NON-BASE MEMBER OF EACH CLASS HAVE THE
*         LEVEL SPECIFICATION OF BASE.
*                (X5)= O.COM
  
  
 CLE50    SA1    O.ECT
          SA1    X1-1        ECIND= FWA(ECT)-1
 CLE60    SA1    A1+B5       ECTB= ECT(ECIND+1) 
          ZR     X1,CLE      IF END OF ECT TABLE
          LX1    EC.NMP 
          SB2    X1          NMB= NM[ECTB]
          SX4    B0          LEVBLK= 0           */BLOCK LEVEL NUMBER 
          MX7    -L.RB
          LX1    EC.NMP-EC.SYMP+1 
          SB1    X1+B5       STINDB= 2* SYM[ECTB]+1 
          SA3    A0-B1       SYMBB= SYMTAB(STINDB)
          BX6    -X0*X3      LEVB= (LVL,LCM) [SYMBB]
          AX3    P.RB 
          SB4    B0          CMIND= 0 
          BX2    -X7*X3      RBB= RB[SYMBB] 
          SX3    -B5         IND= -1
          ZR     X2,CLE70    IF RBB  EQ  0
          SA3    ORGTAB-1+X2       IND= PNT[ORGTAB(RBB)]
  
 CLE70    ZR     X6,CLE80    IF LEVB  EQ  0 
          MI     X3,CLE80    IF IND  LT  0 (LOCAL)
  
*         BASE ALREADY HAS LEVEL SPECIFICATION, CHECK LEVEL CONFLICT
*         WITH BLOCK LEVEL SPECIFICATION. 
  
          NZ     X4,CLE75    IF LEVBLK  EQ  0 
          BX4    X6          LEVBLK= LEVB 
          EQ     CLE80
  
 CLE75    BX7    X6-X4
          ZR     X7,CLE80    IF LEVB  EQ  LEVBLK
          IX2    X5+X3
          MX7    1
          SA2    X2          CH= COMTAB(IND)
          LX7    1+CH.LEEP
          BX7    X2+X7
          SA7    A2          LEE[CH]= 1 
  
*         CLASS MEMBER. 
*                (X3)= IND (-1 IF LOCAL)
*                (A1)= ECTB 
*                (X6)= LEVB 
  
 CLE80    SB4    B4+B5       CMCNT= CMCNT+1 
          GT     B4,B2,CLE60       IF CMCNT  GT  NMB
          SA1    A1+B5       ECTM= ECT(ECIND+1) 
          LX1    -EC.SYMP+1 
          SB3    X1+B5       STINDM= 2* SYM[ECTM]+1 
          SA2    A0-B3       SYMBM= SYMTAB(STINDM)
          BX1    -X0*X2      LEVM= (LVL,LCM) [SYMBM]
          NZ     X1,CLE80    IF LEVM  NE  0 
          ZR     X6,CLE80    IF LEVB  EQ  0 
          BX7    X2+X6
          SA7    A2          (LVL,LCM) [SYMBM]= LEVB
          MI     X3,CLE80    IF IND  LT  0
          IX2    X3+X5
          SA2    X2          CH= COMTAB(IND)
          MX7    1
          LX7    1+CH.NALP
          BX7    X2+X7
          SA7    A2          NAL[CH]= 1 
          EQ     CLE80
  
*         LOCAL LEVEL/EQUIVALENCE ERROR.
  
 CLE.E    SA5    O.ECT
          SX6    A1          SAVE A1
          SX2    B6-B5       STINDB= ERFLAG-1 
          IX6    X6-X5
          SA6    TEMPR
          AX2    1           SYMORD= STINDB/2 
          RJ     PSYM 
          POSTER NR=E.LEE,SEV=FE,FMT=DPC,TXT=X3 
          SA1    TEMPR
          SA2    O.ECT
          IX1    X2+X1
          SA1    X1 
          MX0    -L.LVL-1 
          LX0    P.LCM
          SA5    O.COM
          EQ     CLE10
 CCL      SPACE  4,10 
**        CCL - COORDINATE COMMON LEVEL INFORMATION.
* 
*               SCAN THE COMMON TABLE TO ENSURE THAT NO TWO ITEMS HAVE
*               HAVE CONFLICTING LEVELS.
*               ISSUE AN INFORMAL MESSAGE IF NOT ALL MEMBERS OF THE 
*               COMMON BLOCK WERE MENTIONED IN LEVEL DECLARATIONS, THEN 
*               SET ALL MEMBERS TO THE SPECIFIED LEVEL.  FOR LCM RESIDENT 
*               COMMON BLOCKS, SET LCM[CH.] FOR THE FIRST COMMON HEADER 
*               WORD OF THE BLOCK.
*               CALLED ONCE BEFORE AND AFTER THE EQUIVALENCE PROCESSING.
  
  
 CCL      SUBR                     ENTRY/EXIT.
          BX7    X7-X7             CBLEV=0
          SA3    LEVEL
          ZR     X3,EXIT.          IF NO LEVEL STATEMENTS 
          SA5    N.COM
          ZR     X5,EXIT.          IF NO COMMON DECLARATIONS
          SA5    ORGTAB            I=0
          SA1    O.COM
          SA4    SYM1 
          SX4    X4-1              (X4) = SYM1 -1 
          SA0    X1                (A0) = FWA(T.COM)
          MX0    -L.LVL 
  
*         PROCESS NEXT COMMON BLOCK.
*         (A5,X5) = ORGTAB (I)
*         (X0)    =  M(-L.LVL)
*         (A0)    =  FWA(T.COM) 
  
 CCL10    SB1    X5                CHIND=PNT[ORGTAB(I)] 
          SB7    B0                ERROR FLAG = 0 
          SB1    B1+A0             CHF = T.COM(CHIND) 
          SB2    B1                CHA = CHF
  
*         PROCESS NEXT COMMON BLOCK HEADER IN THE BLOCK.
  
 CCL20    SA1    B2                CHI = (CHA)
          LX1    -CH.LNKP 
          SB6    X1                CHLNK = LNK[CHI] 
          ERRNZ  18-CH.LNKL 
          LX1    CH.LNKP-CH.NMP 
          SB3    B5                CMIND = 1
          SB4    X1                NMEM = NM[CHI] 
          ERRNZ  18-CH.NML
  
*         PROCESS NEXT MEMBER OF THIS COMMON BLOCK APPEARANCE.
  
 CCL30    SA2    B2+B3             CMI = (CHA + CMINK ) 
          LX2    -CM.SYMP 
          SX2    X2 
          ERRNZ  18-CM.SYML 
          LX2    1
          IX3    X4-X2
          SA1    X3                WBI = TSYM(2*SYM[CMI]) 
          LX1    -P.LVL 
          BX5    -X0*X1            MLEV = LVL[WBI]
          BX3    X7-X5
          BX3    -X0*X3 
          ZR     X3,CCL80          IF CBLEN .EQ.MLEV
          ZR     X7,CCL60          IF CBLEV .EQ. 0
          NZ     X5,CCL50          IF MLEV  .NE. 0
          BX6    X1+X7
          LX6    P.LVL
          SA6    A1                LVL[WBI] = 1 
          EQ     CCL70             MARK NOT ALL MEMBER LEVELED
  
*         CONFLICTING LEVELS DECLARED.
  
 CCL50    SX2    B7 
          LX2    58 
          MI     X2,CCL60          IF CONFLICT ALREADY FLAGGED
          MX2    1
          SA3    B1                CHF =  FIRST BLOCK HEADER WORD 
          LX2    1+CH.CLCP
          BX6    X2+X3
          SB7    B7+2              INDICATE CONFLICT ALREADY FLAGGED
          SA6    A3                CLC [CHF] = 1
          EQ     CCL80
  
*         SET BLOCK STANDARD LEVEL. 
  
 CCL60    SX7    X5-MN.LCM
          MX6    1
          BX6    -X7*X6            SIGN BIT ON FOR LCM
          LX6    1+P.LCM-P.LVL
          BX7    X5+X6             STANDARD LEVEL AND LCM BIT 
          NE     B3,B5,CCL70       IF NOT FIRST MEMBER
          EQ     B2,B1,CCL80       IF THIS IS THE FIRST BLOCK APPEARANCE
  
*         FLAG NOT ALL MEMBERS LEVELED AND GO OVER THE
*         ENTIRE BLOCK ONCE AGAIN TO SET LEVEL FOR EACH OF
*         THE MEMBER. 
  
 CCL70    SX2    B7 
          LX2    59 
          MI     X2,CCL80          IF ERROR ALREADY FLAGGED 
          MX2    1
          SA3    B1                CMF = FIRST BLOCK HEADER WORD
          LX2    1+CH.NALP
          BX6    X2+X3
          SB7    B5+B7             INDICATE NOTE ALREADY FLAGGED
          SA6    A3                NAL[CHF] = 1 
          SB2    B1                CHA = CHF
          EQ     CCL20             PASS OVER COMTAB AGAIN TO SET LEVEL
  
 CCL80    SB3    B3+B5             CMIND = CMIND + 1
          LE     B3,B4,CCL30       IF MORE MEMBERS
          SB2    B2+B6             CHA = CHA + CHLNK
          NZ     B6,CCL20          IF MORE BLOCK APPEARANCES REMAIN 
  
*         SET LCM[CHF] BIT IF LCM[WBI] = 1. 
*                 (A1) = WBI  LAST PROCESSED
  
          SX5    B5 
          SA1    A1                WBI
          LX1    -P.LCM 
          BX7    X5*X1             LCM[WBI] 
          SA3    B1                CHF = FIRST BLOCK HEADER WORD
          LX7    CH.LENL+CH.LENP-1
          BX7    X7+X3
          SA7    A3                LCM[CHF] = 1 
  
          SA5    A5+B5             I=I+1
          MX7    0                 ERROR FLAG = 0 
          NZ     X5,CCL10          IF MORE BLOCKS TO GO 
          EQ     EXIT.
          TITLE              ACA - ASSIGN COMMON ADDRESS S
**        ACA - ASSIGN COMMON ADDRESS"S 
* 
*         ASSIGNS RELATIVE ADDRESS"S TO COMTAB ENTRIES
*         COMPUTES LENGTH OF EACH BLOCK, AND STORES RELATIVE ADDRESS
*         IN DIMTAB FOR ENTRIES HAVING THEM 
* 
*         BLOCK MEMBER ENTRIES ARE REFORMATTED AS:  
*         6/0,18/BLOCK LEN,18/N.MEMBERS,18/LINK 
*         AND THE NAMES BECOME: 
*         1/DIMFLAG,5/0,18/LENGTH,18/SYMORD,18/RA 
* 
  
 ACA
          SA5    N.COM
          ZR     X5,ACA            IF NO COMMON 
          SA5    ORGTAB      BLOCK NAME AND INDEX 
  
 ACA0     SA4    SYM1 
          SX4    X4-1              X4 = SYM1-1
          SA3    O.DIM
          SB7    X3-1              INDEX TO DIM TAB 
          SX7    B0                BLOCK LENGTH = 0 
  
 ACA1     SA1    O.COM
          SB1    X5 
          SB1    X1+B1       O.COM + ORGTAB(I)
          SA0    B1          FWA OF THIS BLOCK
          SB2    B0          INITIALIZE BLOCK-TOO-LONG FLAG 
  
 ACA2     SA1    A0          BLOCK NAME WORD
          SB6    X1                LINK 
          AX1    18 
          SB3    B5                LOOP INDEX 
          SB4    X1                NUMBER OF MEMBERS IN THIS APPEARANCE 
          MX5    L.DIMP 
          LX5    L.DIMP+P.DIMP
  
 ACA3     SA2    A0+B3       MEMBER 
          IX6    X7+X2             ADD ADDRESS
          AX2    18-1 
          IX3    X4-X2
          SA1    X3                WORD B 
          BX3    X5*X1
          AX1    P.TYP
          AX3    P.DIMP-1          DIMP INDEX 
          SX2    X1-T.DBL 
          ZR     X3,ACA4           IF NO DIM ENTRY
  
*         DIMENSIONED VARIABLE - SET DIM BIT IN COMTAB AND GET WC 
  
          MX0    1
          SA3    X3+B7             WORD 2 OF DIM ENTRY
          BX6    X0+X6             SET DIM ENTRY FLAG 
          AX3    36 
          SX0    X3                X0 = WC
          SA7    A3-B5             RA TO DIM ENTRY
          NZ     X0,ACA6           IF REALLY DIMENSIONED
  
 ACA4     SX3    B5 
          AX2    L.TYP
          BX1    -X2*X3            0 IF SINGLE , 1 IF DOUBLE
          SX0    X1+B5
  
*         SUM BLOCK LENGTH, UPDATE COMTAB ENTRY 
  
 ACA6     IX7    X7+X0             BL = BL+WC 
          MX2    -17
          BX2    X2*X7
          ZR     X2,ACA6.A   IF BLOCK LENGTH .LE. 1S17-1
          SX7    377777B     BL = 1S17-1
          SB2    X7          ERROR FLAG .NE. 0
  
 ACA6.A   LX0    36 
          BX6    X0+X6             ADD WORD COUNT TO ENTRY
          SA6    A0+B3
          SB3    B3+B5             ADVANCE LOOP INDEX 
          LE     B3,B4,ACA3 
  
          SA0    A0+B6       BASE = BASE + LINK 
          NZ     B6,ACA2           IF MORE APPEARENCES TO GO
  
          SA1    B1                FIRST BLOCK MEMBER APPEARENCE
          LX7    36 
          IX7    X7+X1             INSTALL BLOCK LENGTH 
          SA7    A1 
  
          SA5    A5+B5             NEXT BLOCK 
          SX7    B0                BLOCK LENGTH = 0 
  
          ZR     B2,ACA6.B   IF BLOCK NOT TOO LONG
          SA1    A5-B5       ORGTAB HEADER FOR BLOCK
          MX0    42 
          SX3    1R 
          SX7    A5 
          BX4    X0*X1       NAME 
          SA7    TEMPREG
          LX4    -12
          BX7    X4+X3
          POSTERR  NR=E.BLKL,SEV=FE,FMT=DPC,TXT=X7
          SA1    TEMPREG
          SA5    X1 
          NZ     X5,ACA0     IF MORE BLOCKS TO PROCESS
          EQ     ACA
  
 ACA6.B   NZ     X5,ACA1     IF MORE BLOCKS TO PROCESS
          EQ     ACA
 PDC      TITLE  PDC - PERFORM DEFERRED CHECKS
**        PDC - PERFORM DEFERRED CHECKS.
  
  
 PDC      ENTRY. *                 ** ENTRY/EXIT ** 
          SA3    DBLDECL
          SA5    SYM1 
          ZR     X3,PDC.L          IF NO TYPE DOUBLE OR COMPLEX DECLAR
  
*         SCAN DIMTAB FOR DOUBLE PREC OR COMPLEX ARRAYS AND DOUBLE
*         THEIR LENGTHS.
  
          SA1    O.DIM
          SA2    L.DIM
          SB6    X1                FWA OF DIMTAB
          SB7    B6+X2             LWA+1
          SB2    B5+B5             B2 = 2 
          MX4    3
          LX4    3+54              TO EXTRACT VAR DIM FLAGS 
          SB3    -B5               B3 = -1
          MX0    17 
          LX0    17+36             MASK TO EXTRACT TOTAL WC 
  
 PDC1     SA1    B6                WORD 1 OF DIM ENTRY
          GE     B6,B7,PDC.L       IF FINISHED
          AX1    36-1 
          IX2    X5-X1
          SA3    X2+B3             WORD B OF SYMTAB ENTRY 
          SB6    B6+B2
          AX3    P.TYP
          SB4    X3-T.DBL 
          NG     B4,PDC1           IF SINGLE PRECISION
          GT     B4,B5,PDC1        IF NOT TYPE DOUBLE OR COMPLEX
          SA1    A1+B5             WORD 2 OF DIM ENTRY
          BX7    X4*X1
          NZ     X7,PDC1           IF VARIABLE DIMS 
          BX2    X0*X1
          IX6    X2+X1             DOUBLE TOTAL WORD COUNT
          SA6    A1 
          EQ     PDC1 
          SPACE  3
 PDC.L    RJ     CCL               COORDINATE COMMON LEVEL INFO 
          SPACE  2
 PDC.V    SA3    VARDIM 
          ZR     X3,PDC2           IF NO VARIABLE DIMENSIONED ARRAYS
  
*         SCAN F.P. S IN SYMTAB AND CHECK TO SEE THAT ANY USED AS 
*         SUBSCRIPTS TO ARRAYS ARE TYPE INTEGER 
  
          SA5    SYM1 
  
 PDC.V1   SA1    X5-2 
          SB1    59-P.FP
          SB2    59-P.RL
          SX7    1R 
  
 PDC.VL   SA1    A1-2              WORD A 
          SA2    A1-B5             WORD B 
          LX3    B1,X1
          PL     X3,PDC2           IF NOT AN F.P. 
          LX4    B2,X2
          PL     X4,PDC.VL         IF NOT USED AS AN ARRAY SUBSCRIPT
          AX2    P.TYP
          SB3    X2 
          EQ     B3,B5,PDC.VL      IF TYPE INTEGER
  
          SX6    A1+2 
          SA6    TEMP              SAVE SYMTAB ADDRESS
          MX0    L.NAME 
          BX3    X0*X1
          AX3    12 
          SX4    B0 
          BX3    X3+X7             X3 = 8R_NAME 
          SB6    E.FPNI 
+         SB7    *+1               RETURN ADDRESS 
          EQ     ERPRO
  
          SA5    TEMP 
          EQ     PDC.V1 
  
*         INITIALIZE FOR EQUIVALENCE PROCESSING.
*         CREATE DIM ENTRIES FOR ALL MEMBERS OF NON-COMMON EQUIVALENCE
*         GROUP WHICH DO NOT ALREADY HAVE ONE, AND MARK COMMON BLOCKS 
*         INVOLVED IN EQUIVALENCE.
  
 PDC2     SA2    L.EQV
          MX6    -1 
          ZR     X2,PDC      IF NO EQUIVALENCE STATEMENTS 
          ADDWD  EQV,X6      ADD TERMINATOR WORD
          SA1    O.EQV
          SA2    L.DIM
          SB1    X1          I= FWA OF EQV TABLE
          MX0    L.DIMP 
          SA3    O.COM
          SA4    SYM1 
          LX0    L.DIMP+P.DIMP
          SB3    B5+B5
          MX7    -L.RB
          SA0    X4 
          SB7    X2          DIMJ= (L.DIM)
          MX5    1
          LX5    1+CH.EQUP
  
 PDC4     SA1    B1          EQV1(I)
          SB1    B1+B3       I= I+2 
          MI     X1,PDC8     IF END OF EQV TABLE
          LX1    -E1.SY2P 
          SB4    X1+B5       STIND= SY2[EQV1(I)]+1
          SA2    A0-B4       SYMB= SYMTAB(STIND)
          BX4    X0*X2       DIMP= DIMP[SYMB] 
          LX2    -P.RB
          BX6    -X7*X2      RBI= RB[SYMB]
          NZ     X6,PDC6     IF RBI  NE  0
          NZ     X4,PDC4     IF DIMP  NE  0 
          SX6    B7+B3       DIMP= DIMJ+2 
          LX6    P.DIMP-1 
          LX2    P.RB 
          BX6    X6+X2
          SA6    A2          DIMP[SYMB]= DIMJ 
          SB7    B7+B3       DIMJ= DIMJ+2 
          EQ     PDC4 
  
*         FOR THOSE IN COMMON, MARK EQU BIT ON BLOCK HEADER.
  
 PDC6     SA4    ORGTAB-1+X6  IND= PNT[ORGTAB(RBI)] 
          IX4    X3+X4
          SA1    X4          CHI= COMTAB(IND) 
          BX6    X5+X1
          SA6    A1          EQU[CHI]= 1
          EQ     PDC4 
  
*         FOR EACH EQUIVALENCED COMMON BLOCK, CREATE DIM ENTRIES FOR
*         THOSE MEMBERS THAT DO NOT ALREADY HAVE ONE. 
*                (X3)= O.COM
  
 PDC8     SA1    N.COM
          SA5    ORGTAB-1    ITAB= 0
          ZR     X1,PDC16    IF NO COMMON BLOCKS
  
 PDC9     SA5    A5+B5       ITAB= ITAB+1 
          IX4    X3+X5       IND= PNT[ORGTAB(ITAB)] 
          ZR     X5,PDC16    IF NO MORE BLOCKS TO GO
          SA1    X4          CHI= COMTAB(IND) 
          LX1    -1-CH.EQUP 
          SB2    B0          LINK= 0
          PL     X1,PDC9     IF EQU[CHI]  NE  1 
  
 PDC10    SA1    A1+B2       CHI= COMTAB(IND+LINK)
          LX1    -CH.LNKP 
          SB2    X1          LINK= LNK[CHI] 
          LX1    CH.LNKP-CH.NMP 
          SB6    X1          N.MEM= NM[CHI] 
 PDC12    ZR     B6,PDC14    IF NO MORE MEMBERS 
          SA2    A1+B6       CMI= COMTAB(IND+N.MEM) 
          LX2    -CM.SYMP+1 
          SB4    X2+B5       STIND= SYM[CMI]+1
          SA4    A0-B4       SYMB = SYMTAB(STIND) 
          BX6    X0*X4       DIMP= DIMP[SYMB] 
          SB6    B6-B5       N.MEM= N.MEM-1 
          NZ     X6,PDC12    IF DIMP  NE  0 
          SX7    B7+B3       DIMP= DIMJ+2 
          SB7    B7+B3       DIMJ= DIMJ+2 
          LX7    P.DIMP-1 
          BX6    X7+X4
          SA6    A4          DIMP[SYMB]= DIMP 
          EQ     PDC12
  
 PDC14    NZ     B2,PDC10    IF LNK[CHI]  NE  0 
          EQ     PDC9 
  
*         UPDATE DIMTAB LENGTH, CLEAR OUT NEW ENTRIES.
  
 PDC16    SA2    L.DIM
          SX7    B7 
          SB6    X2 
          EQ     B6,B7,PDC   IF NO CHANGE IN L.DIM
          SA7    TEMP 
          ALLOC  DIM,B7-B6   ALLOCATE FOR THE EXTRA DIM ENTRIES 
          SA1    O.DIM
          SA2    L.DIM
          IX1    X1+X2       STARTING ENTRY TO BE CLEARED 
          SA3    TEMP        NEW L.DIM
          BX6    X3 
          SA6    A2          L.DIM= NEW L.DIM 
          IX2    X3-X2       NO. ENTRIES TO BE CLEARED
          SETZERO X1,X2 
          EQ     PDC
 ETC      TITLE  ETC - ENTRY POINT, TRACEBACK, AND F.P. INFO TO COMPS 
**        ETC - ENTRY POINT, TRACEBACK, AND F.P. INFO TO COMPS. 
* 
*         ENTRY  (B5) = 1 
* 
*         CALLS  ESF     *PH1CTL* 
*                FMAC    *STMTP*
*                F1AMAC  *STMTP*
*                OUTUSE  *LSTPRO* 
*                SVARG   *STMTP*
  
  
 TNFP     EQU    NARGS+12          SCRATCH CELL IN /MACBUF/ 
*                                  FOR *FORPAR* LOOP. 
  
  
 ETC      ENTRY. *                 ** ENTRY/EXIT ** 
  
          SA1    PROGRAM
          UX1    B2,X1
          LE     B2,B0,ETC         IF A PROGRAM OR BLOCK DATA SUBPROG 
  
          RJ     =XESF             ENTER SPECIAL SYMBOLS IN SYMTAB
  
          OUTUSE START. 
  
*         ISSUE *TRACE* MACRO TO COMPS. 
  
          INTARG
          SX6    B5 
          SVARG  NAME,B5           ARG 1 = PROGRAM NAME 
          SX6    B5 
          SVARG  NAME,2            ARG 2 = PROGRAM NAME 
          SA1    =XTEMPA0.
          SA2    =XN.FP 
          ZR     X1,ETC1           IF NO FP S OR RETURNS
          SX6    X2 
          SVARG  OCT,3             ARG 3 = NUMBER OF FP S 
  
 ETC1     NARGS= B7 
          FMAC   TRACE             OUTPUT TRACE MACRO CALL
  
*         ISSUE *PENTRY* MACRO TO COMPS.
  
          INTARG
          SX6    B5 
          SVARG  NAME,B5           ARG 1 = PROGRAM NAME 
          SA1    =XENTRY. 
          BX6    X1 
          SVARG  NAME,2            ARG 2 = ENTRY. 
          SA1    =XFUNTYPE
          BX6    X1 
          SVARG  INT,3             ARG 3 = WDS IN FUNCTION RESULT 
          SA1    =XCO.ER
          SA2    =XSTART. 
          LX6    B5,X1
          IX7    X2+X6
          SA7    A2          START. = START.+1  */IF ER"0 
          SVARG  INT,4       ARG4=ER
          NARGS= B7 
          FMAC   PENTRY            OUTPUT PENTRY MACRO CALL 
  
          SA1    =XN.FP 
          ZR     X1,ETC            IF NO F.P. S 
  
          SA3    =XMACFLAG
          ZR     X3,ETC            IF F.P.S DONT HAVE TO BE OUTPUT
  
*         ISSUE *FORPAR* MACRO CALLS TO COMPS TO ESTABLISH THE ORDER
*         OF THE F.P. BLOCKS. 
  
          SX6    0
          SA6    TNFP 
  
 ETC2     SX6    X6+2              SYMTAB ORD OF F.P. 
          F1AMAC FORPAR            OUTPUT *FORPAR* MACRO CALL 
          SA1    TNFP 
          SA2    =XN.FP 
          SX6    X1+B5             TNFP=TNFP+1
          NO
          IX0    X6-X2             TNFP-N.FP
          SA6    A1 
          MI     X0,ETC2           IF MORE F.P.S
          EQ     ETC               EXIT 
  
 O.CET    END                      FWA OF COMMON EQUIVALENCE TBL
