*DECK,FAX 
          IDENT  FAX
 FAX      TITLE  FAX - FTN INTERNAL ASSEMBLER 
*CALL     SSTCALL 
          NOREF  CSAVE
          NOREF  ILL
          NOREF  LOOKI
          NOREF  LOOKS
          NOREF  MOVMAX 
          NOREF  MOVT 
          NOREF  ORGB 
          NOREF  ORGFWA 
  
 B=FAX    RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          EXT    TEMPA0.,TRACE.,ENTRY.,FTNNOP.,NOPS.,ST.
          EXT    FV.LGO 
          EXT    F.CMPS 
          EXT    F.LGO
          EXT    N.FILES
          EXT    N.FP 
          EXT    OLIST
          EXT    WB.LAB 
          EXT    XFRNAME
          USE    DEBUG
          USE    *
  
          TABLES  ENTR,EXT,TSS
          SPACE  3
**        FAX - FTN INTERNAL ASSEMBLER. 
* 
*         FUNCTION -
*          TO ASSEMBLE THE "COMPS" FILE AND PLACE THE RELOCATABLE 
*          BINARY ON THE "LGO" FILE.
*          FAX IS A 1 PASS ASSEMBLER BY VIRTUE OF THE FACT THAT 
*          PREVIOUS PASS"S HAVE CALCULATED THE PROGRAM LENGTH, BLOCK
*          LENGTHS AND DEFINED THE ADDRESS"S OF ALL SYMBOLS FOR IT. 
* 
 .JOL     EQU    1           "0 FOR JUSTIFIED O LIST ( COST 2 PERCENT ) 
          SPACE  3
          EJECT 
**        CONSTANTS, TABLES AND WORKING STORAGE.
  
*         JOB COMMUNICATIONS AREA USAGE.
  
 SYM1     =      RA.SSW+12B        CONTAINS INVERTED FWA SYMBOL TABLE 
 PROGRAM  =      RA.SSW+56B        CONTAINS PROGRAM UNIT TYPE 
  
  
 N.LRB    =      7                 NUMBER OF LOCAL RELOCATION BASES 
  
          USE    /TABLES/ 
 BLKCOM   BSS    1                 ADDR OF BLANK COMMON IN ORGTAB 
 L.PROG   BSS    1                 PROGRAM LENGTH 
 O.LRB    BSS    N.LRB             FWA OF LOCAL RELOCATION BASES
          BSS    5
 L.PROGP  BSS    1
          BSS    4
 AERCNT   BSS    1                 ASSEMBLY ERROR COUNT 
 STOVSIZE BSS    1                 AMOUNT OF STORAGE OVERFLOW 
 ERRLINE  BSS    10          ERROR MESSAGE LINE 
          USE    *
  
  
  
*         PREFIX (77) TABLE.
  
 OBJIMULT EQU    1                 INTEGER MULTIPLY ALWAYS ON 
 IMUL     MICRO  1,,/I/      INTEGER MULTIPLY ON ( ALWAYS ) 
 MODLVL   MICRO  1,5,$"MODLVL"     $
  
 L.PRFX   =      15D
  
  
  
**        TARGET - TWO CHARACTERS INDICATING THE TYPE OF PROCESSOR FOR
*                  WHICH THE PROGRAM IS OPTIMIZED.
* 
*         VALID - TWO CHARACTERS INDICATING THE TYPE OF PROCESSOR ON
*                 WHICH THE PROGRAM CAN BE EXECUTED.
* 
*         TARGET  AND  VALID  ARE CALCULATED FROM  MODEL
* 
*         MODEL      -->      TARGET     -->      VALID 
*         71                  64                  64
*         72                  64                  64
*         73                  64                  64
*         74                  66                  6X
*         76                  76                  7X
*         171                 64                  64
*         172                 64                  64
*         173                 64                  64
*         174                 64                  64
*         175                 C5                  CX
*         176                 76                  7X
* 
  
 .TMP     MICRO  2,1,/"MDL"/
 TARGET   MICRO  2*".TMP"-5,2,/6466C576/
 VALID    MICRO  2*".TMP"-5,2,/646XCX7X/
 PREFIX   BSS    0
          LIST   A
          LOC    0
          VFD    6/77B,12/0,6/L.PRFX-1,36/0 
          DATA    1H               PROGRAM UNIT NAME
          DATA    1H               MM/DD/YY - DATE
          DATA    1H               HH.MM.SS - TIME OF DAY 
          DATA   10H"OS.ID" 
          DATA   10H"LPNAME""VER" 
          VFD    30/5H"MODLVL",12/2H"TARGET",12/2H"VALID",6/1H
          DATA    2H "IMUL"        HARDWARE DEPENDENCIES
          DATA   1H                PROGRAM UNIT TYPE
          DATA    1H               CONTROL CARD OPTIONS 
          DATA    1H               CONTROL CARD OPTIONS 
          BSSZ   L.PRFX-*L
          LOC    *O 
          LIST   *
  
  
  
  
*         LDSET (70) TABLE USED BY SCOPE 3.4 LOADER.
  
 LDUSE6   DATA   0LFORTRAN
          DATA   0
  
*         MAP AND PRESET TABLES USED BY PMDMP 
 PMDUSE   VFD    12/0011B,12/1,18/0,17/3,1/1  SELECT *BS* MAP OPTION
          DATA   0LZZZZZMP                    ON FILE *ZZZZZMP* 
          VFD    12/0012B,12/1,18/0,18/1      PRESET CORE TO            000200
          VFD    60/60000000000433400000B     SB0 A0+0,  EQ B3,B3,*+1S17
          DATA   0                                                      000220
  
  
  
*         CONSTANTS AND WORKING STORAGE.
  
 SWC      ENTRY. 0                 INPUT LINE LENGTH (WORDS)
  
          USE    IO$$              FORCE OUT 7RM MACRO EXPANSION CODE 
          BSS    0
          USE    *
  
          USE    STORAGE
 MEMORY   BSS    0                 FWA WORKING STORAGE
          USE    *
  
 SCRSIZE  EQU    11 
 SCRATCH  EQU    MEMORY 
 LINE     EQU    MEMORY+SCRSIZE    14 WORD WORK AND PRINT BUFFER
 ISHIFT   EQU    5
 ILINE    EQU    LINE+ISHIFT       SOURCE LINE STORED HERE
 LINESIZE EQU    15 
 GLAPR    BSS    1           GL/AP RELOCATION SKELETON
 MEMSTRT  VFD    60/MEMORY+SCRSIZE+LINESIZE 
 CORGTAB  BSS    1                 POINTER TO COMMON ORGTAB 
 LORGTAB  BSS    1                 POINTER TO LOCAL ORGTAB
 LINKTAB  BSS    1                 POINTER TO EXTERNAL NAME TABLE 
 FREEMEM  BSS    1                 POINTER TO NEXT FREE WORKING STG. LOC
 TEXT.ADD BSS    1                 POINTER TO CURRENT ORGTAB ENTRY
 MEMEND   BSS    1                 LWA WORKING STORAGE
 ALABEL   BSS    1                 LABEL IS SAVED HERE
 FFLAG    BSS    2                 FORCE UPPER FLAG 
 NFLAG    EQU    FFLAG+1           FORCE UPPER, NEXT INSTRUCTION FLAG 
 IOCTR    CON    0           ]IONNN COUNTER 
 LDUSE    CON    LDUSE6      FWA OF LDSET (70) TABLE
 XFL      CON    18          LENGTH OF XFILL RELOCATION FIELD (LCM=D) 
 LFL      SET    60-P.RL
 LRB      SET    P.RL-P.RB
 WBDATA.  VFD    LFL/1,LRB/4,P.RB/0 
          SPACE  2
*         DEFINITION OF RELOCATION CODES USED BY THE LOADER 
  
 RL$      EQU    00B
 RL$L     EQU    02B
 RL$M     EQU    04B
 RL$U     EQU    10B
 RL$B     EQU    12B
  
 PTRS     MACRO  NAME 
 PTR.NAME SNAP   MEMSTRT,ALABEL 
          ENDM
  
 COMTAB   MACRO  N
 COM.N    SNAP   *CORGTAB,*LORGTAB
          ENDM
  
 LINKTAB  MACRO  N
 LNK.N    SNAP   *LINKTAB,*MEMSTRT
          ENDM
  
 CHAINS   MACRO  N
 CHN.N    SNAP   *MEMSTRT,*FREEMEM
          ENDM
          TITLE              MACRO DEFINITIONS
**********************************************************************
*                                                                    *
*         ASSEMBLING FTNXAS WITH DEBUG SET TO 1 WILL CAUSE-          *
*                                                                    *
*                   1.SNAP CALLS TO BE MADE AT STRATEGIC POINTS      *
*                   2.CODE TO NOT BE RELOCATED TO THE OPCODE VECTORS *
*                   3.THE LAST FEW WORDS OF L3.JVEC TO BE ASSEMBLED  *
*                                                                    *
**********************************************************************
          SPACE  2
 DEBUG    EQU    0
  
*** 
*         RELOC - GENERATE A WORD OF 4 BIT RELOCATION BYTES FOR "WRSEQ" 
* 
 RELOC    MACRO  Q
          IRP    Q
          VFD    4/RL$Q 
          IRP 
          VFD    *P/0 
          ENDM
          SPACE  2
* 
* GCH AND CWD ARE USED THROUGHOUT THE ASSEMBLER FOR SCANNING THE INPUT
* STRING. 
* 
 GCH      MACRO  Z
          A_Z    X5,B4
          SB4    B4-B6
          B_Z    -X0*_Z 
          ENDM
          SPACE  2
 CWD      MACRO 
 +        PL     B4,*+1 
          SA5    A5+B5
          SB4    B7 
          ENDM
* 
* THE FOLLOWING SYSTEM OF MACROS IS USED TO RELOCATE CODE BLOCKS INTO 
* UNUSED PORTIONS OF THE OPCODE VECTORS WHEN "MOVMAC" IS SET TO 0 
* 
 MOVMAC   EQU    TEST+DEBUG 
          SPACE  2
 MOVMAX   EQU    10000B 
 ORGORD   SET    0
 CSAVE    SET    0
          SPACE  2
 IFM      IFEQ   MOVMAC,0 
  
 ORGSTART MACRO 
          BSS    0
 ORGFWA   SET    *
 ORGORD   SET    ORGORD+1 
          ENDM
          SPACE  2
 ORGEND   MACRO 
          BSS    0
 OC       DECMIC ORGORD,3 
 ORGN"OC" SET    *-ORGFWA 
 ORGL"OC" SET    ORGFWA 
          ENDM
  
 IFM      ELSE
 ORGSTART OPSYN  NIL
 ORGEND   OPSYN  NIL
 MOVSTART OPSYN  NIL
 MOVEND   OPSYN  NIL
 IFM      ENDIF 
  
 LOOK     MACRO  A
 LOOKI    SET    LOOKI+1
 LOOKC    DECMIC LOOKI,3
          IFGE   ORGN"LOOKC",A,3
          IFLT   ORGN"LOOKC",LOOKS,2
 LOOKS    SET    ORGN"LOOKC"
 LOOKSC   MICRO  1,,$"LOOKC"$ 
          IFLT   LOOKI,ORGORD,1 
          LOOK   A
          ENDM
          SPACE  2
 IFMM     IFEQ   MOVMAC,0 
  
 MOVSTART MACRO  A
 MSIDENT  MICRO  1,,$"SEQUENCE"$
          BSS    0
 LOOKS    SET    MOVMAX 
 LOOKI    SET    0
          LOOK   A
 MSLEN    SET    A
          IFNE   LOOKS,MOVMAX,5 
 CSAVE    SET    CSAVE+A
 ORGB     SET    *
          ORG    ORGL"LOOKSC" 
 ORGL"LOOKSC"  SET  ORGL"LOOKSC"+A
 ORGN"LOOKSC"  SET  ORGN"LOOKSC"-A
 MSORG    SET    *
          ENDM
  
  
  
 MOVEND   MACRO 
          BSS    0
          IFNE   *,MSORG+MSLEN,2
 TRUELEN  OCTMIC *-MSORG,3
          ERR    MOVSTART CALL AT "MSIDENT" - CODE LENGTH PARAMETER SHOU
,LD BE "TRUELEN"B WORDS.
          IFNE   LOOKS,MOVMAX,1 
          ORG    ORGB 
          ENDM
  
 IFMM     ENDIF 
          SPACE  3
 RL=      MACRO  TYPE              ADJUST RELOCATION AFTER WRITING A WOR
          SX3    RL$TYPE
          BX6    X3+X6
          SA6    A3 
          ENDM
  
 WR1WD    MACRO  WORD,RETURN
          IFC    NE,/WORD//,1 
          SA4    WORD 
          SB1    60 
          SB6    RETURN  *+2-*P/60D 
          EQ     WRTEXT 
          ENDM
 LISTER   SPACE  4,8
**        LISTER - LIST ONE LINE (CONDITIONAL). 
* 
*         LISTS ONE LINE IF BINARY LIST OPTION IS ON (O = .NZ.).
* 
*         ENTRY  *FWA* = LINE ADDRESS 
*                *WC*  = LINE LENGTH (WORDS)
* 
*         USES   A2, X2, B1, B5 
* 
*         CALLS  LISTL (FA=LOL) 
  
  
          PURGMAC   LISTER
  
 LISTER   MACRO  FWA,WC 
          LOCAL  EXIT 
          SA2    OLIST
          SB1    1
          ZR     X2,EXIT
          LISTL  FWA,WC 
          SB5    B1+
 EXIT     BSS    0
 LISTER   ENDM
 STLTAB   SPACE  4,7
**        STLTAB - GENERATE STATIC LOAD WEAK EXTERNAL XLINK TABLE.
* 
*         STLTAB NAME 
* 
*         ARGS   *NAME*   = NAME OF AN *FCL* STATIC LOAD BLOCK. 
* 
*            THIS MACRO GENERATES THE *XLINK* TABLE BODY FOR THE STATIC 
*         LOAD WEAK EXTERNAL TABLE.  THE FINAL CORE ADDRESS ARE PLUGGED 
*         IN LATER BY *FAX* JUST BEFORE WRITING THE WHOLE TO THE BINARY 
*         FILE.  NOTE  HOWEVER  THAT  THE  REST  OF THIS TABLE IS *HARD 
*         WIRED*,  I.E. THERE ARE TWO ADDRESSES PER WORD, FIXED LENGTH, 
*         ETC.. 
  
  
          PURGMAC STLTAB
  
 STLTAB   MACRO  NAME 
          IF     -DEF,T.1,2 
 T.1      SET    N.STL
 S.1      SET    0
 .1       IFEQ   S.1,0
 S.1      SET    30 
 .1       ELSE
 S.1      SET    0
 .1       ENDIF 
          VFD    42/0L_NAME,18/1
          VFD    30/**,6/S.1,6/30,9/0,9/1 
 T.1      SET    T.1-1
          IFNE   T.1,0,1
          CON    0
 STLTAB   ENDM
 W.EXT.   SPACE  4,7
**        GENERATE THE STATIC LOAD WEAK EXTERNAL TABLE. 
  
 S.WEXT   VFD    12/4500B,12/N.STL*3-1,*P/0 
  
*CALL STLOAD
  
 L.WEXT   EQU    *-S.WEXT 
          TITLE              TRANSFER VECTORS 
* 
* COL1VEC IS USED TO MAKE A DECISION ON THE FIRST CHARACTER OF A
* SOURCE STATEMENT. 
* 
 COL1VEC  BSS    0                 COLUMN 1 VECTOR
 +        EQ     ILL               ZERO 
          DUP    32B,1
 +        EQ     PLABEL            A - Z
          ORGSTART
          DUP    12B,1
 +        EQ     ILL               0 - 9
          ORGEND
 +        SX6    1                 +
          EQ     PFC
 +        SX6    -1                -
          EQ     PFC
          EQ     PCOMM             *  COMMENT CARD
 +        EQ     ILL               /
          EQ     PLABEL            (
 +        EQ     PLABEL            )
          ORGSTART
 +        EQ     ILL               $
 +        EQ     ILL               =
          ORGEND
 +        EQ     BLANK             BLANK
 +        EQ     ILL               ,
 +        EQ     PLABEL            .
 +        EQ     PLABEL            #
 +        EQ     PLABEL            [
 +        EQ     PLABEL            ]
          ORGSTART
 +        EQ     ILL               :  
 +        EQ     ILL               "
 +        EQ     ILL               _
 +        EQ     ILL               !
 +        EQ     ILL               &
 +        EQ     ILL               '
          ORGEND
 +        EQ     PLABEL            ?
* 
*         OPERATION CODE RECOGNITION TRANSFER VECTORS 
* 
*                   SET B2 TO FIRST LETTER
*                   SET B3 TO SECOND LETTER 
*                   JP        FLVEC-1+B2
* 
*         FIRST LETTER VECTOR 
* 
 FLVEC    BSS    0
 +        JP     AVEC-1+B3         A
 +        JP     BVEC-1+B3         B
          SX7    1R0
          EQ     L3.CNT 
 +        JP     DVEC-1+B3         D
 +        JP     EVEC-1+B3         E
 +        JP     FVEC-1+B3         F
 PGE      SX4    0600B             G
          EQ     PGNAME            GE OR GNAME
          EQ     PHOL              HOL
 +        JP     IVEC-1+B3         I
 PJP      SX4    0200B       J
          EQ     L3.JP
 +        EQ     ILL               K
 +        JP     LVEC-1+B3         L
 +        JP     MVEC-1+B3         M
 +        JP     NVEC-1+B3         N
          EQ     PORG              ORG
 +        JP     PVEC-1+B3         P
 +        EQ     ILL               Q
 +        JP     RVEC-1+B3         R
 +        JP     SVEC-1+B3         S
 +        EQ     PTRACE            TRACE
 +        JP     UVEC-1+B3         U
          BX3    X3-X3
          EQ     L3.VFD 
 PWX      SX4    1500B
          EQ     L3.RWX 
          ORGSTART
 +        EQ     ILL               X
 +        EQ     ILL               Y
          ORGEND
 #T       IFNE   TEST,0 
+         JP     ZVEC-1+B3
 #T       ELSE
 PZR      SX4    0300B             Z
          EQ     L3.XJP 
 #T       ENDIF 
* 
*         SECOND LETTER VECTORS 
* 
 AVEC     BSS    0                 A VECTOR 
          ORGSTART
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
          ORGEND
 +        EQ     PAPL              APL
          ORGSTART
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PAXI     SX4    21000B            X
          EQ     L3.SH
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 BVEC     BSS    0                 B VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
          SPACE  2
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
          ORGEND
 +        SB2    TLVEC-1           S
          EQ     PNL
          ORGSTART
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 +        EQ     L3.BOOL           X
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
          ORGEND
 DVEC     BSS    0                 D VECTOR 
 +        SB1    1R                A
          EQ     PDATA
          ORGSTART
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
          ORGEND
 +        EQ     PDIS              I
          ORGSTART
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PDXI     SX4    02000B            X
          EQ     L3.ARIT
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 EVEC     BSS    0                 E VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
          ORGEND
+         EQ     L3.ED
          ORGSTART
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
          ORGEND
 +        EQ     PEIO              PROCESS EIO MACRO
          ORGSTART
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
          ORGEND
 +        SB2    TLVEC-1           N
          EQ     PNL
          ORGSTART
 +        EQ     ILL               O
          ORGEND
          EQ     NOBINPO           EPL
 +        SB2    TLVEC-1           Q
          EQ     PNL
 +        EQ     ILL               R, ERR PSEUDO-OP 
          ORGSTART
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 +        EQ     NOBINPO           X
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 FVEC     BSS    0                 F VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
          ORGEND
          EQ     NOBINPO
          ORGSTART
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
          EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
          ORGEND
          MX0    36                FMT
          SA5    A5+B5             NEXT WORD
          EQ     PFMT              FORMAT LABEL DEFINITION
          ORGSTART
 +        EQ     ILL               N
          ORGEND
 P        EQ     NOBINPO
          ORGSTART
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PFXI     BX4    X4-X4
          EQ     L3.ARIT
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 IVEC     BSS    0                 I VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
          ORGEND
 +        EQ     PIDENT            D
          ORGSTART
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
          ORGEND
 +        EQ     PIOM              PROCESS IOM MACRO
          ORGSTART
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PIXI     SX4    06000B            X
          EQ     L3.ARIT
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 LVEC     BSS    0                 L VECTOR 
          ORGEND
          EQ     PLAP 
          ORGSTART
 +        EQ     ILL               B
          EQ     ILL               C
          ORGEND
          EQ     PLDSET            D     PROCESS *LDSET*
          ORGSTART
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
          EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
          ORGEND
 PLT      SX4    0700B             T
          EQ     L3.BJP 
          ORGSTART
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PLXI     SX4    20000B            X
          EQ     L3.SH
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
          ORGEND
 MVEC     BSS    0                 M VECTOR 
          ORGSTART
          EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
          ORGEND
 PMI      SX4    0330B             I
          EQ     L3.XJP 
          ORGSTART
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 +        SX4    43000B            X
          EQ     L3.MX
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
          ORGEND
 NVEC     BSS    0                 N VECTOR 
 +        EQ     PNAME             A
          ORGSTART
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
          ORGEND
 PNE      SX4    0500B             E
          EQ     L3.BJP 
          ORGSTART
 +        EQ     ILL               F
          EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
          ORGEND
 +        SX4    46000B            O
          EQ     L4.15
          ORGSTART
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PNXI     SX4    24000B            X
          EQ     L3.PUN 
 +        EQ     ILL               Y
 PNZ      SX4    0310B
          EQ     L3.XJP 
 PVEC     BSS    0                 P VECTOR 
          ORGSTART
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
          ORGEND
 +        EQ     PPENTRY
          ORGSTART
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
          ORGEND
 PPL      SX4    0320B             L
          EQ     L3.XJP 
          ORGSTART
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PPXI     SX4    27000B            X
          EQ     L3.PUN 
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 RVEC     BSS    0                 R VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
          ORGEND
 +        EQ     PREPI
          ORGSTART
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
          ORGEND
 PRJ      SX4    0100B             J
          EQ     L3.RJ
          ORGSTART
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PRX      EQ     L3.RX
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
          ORGEND
 SVEC     BSS    0                 S VECTOR 
 PSAI     SX4    51000B            A
          EQ     L3.SET 
 PSBI     SX4    61000B            B
          EQ     L3.SET 
          ORGSTART
 +        EQ     ILL               C
 +        EQ     ILL               D
          EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
 +        EQ     ILL               S
 +        EQ     ILL               T
          ORGEND
 +        EQ     PSUB              U
          ORGSTART
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PSXI     SX4    71000B            X
          EQ     L3.SET 
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 UVEC     BSS    0                 U VECTOR 
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
          ORGEND
 +        EQ     PUSE              S
          ORGSTART
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
          ORGEND
 PUXI     SX4    26000B            X
          EQ     L3.PUN 
          ORGSTART
 +        EQ     ILL               Y
 +        EQ     ILL               Z
 #T       IFNE   TEST,0 
 ZVEC     BSS    0
          DUP    1RQ-1RA+1,1
+         EQ     ILL
          ORGEND
 PZR      SX4    0300B
          EQ     L3.XJP 
          ORGSTART
          DUP    1RW-1RS+1,1
+         EQ     ILL
          ORGEND
 PZXI     SX4    25000B 
          EQ     L3.PUN 
          ORGSTART
+         EQ     ILL               Y
+         EQ     ILL               Z
 #T       ENDIF 
* 
* THE LAST 3 VECTORS HAVE BEEN INCLUDED, ALONG WITH THE ROUTINE PNL 
* TO PROVIDE FOR EASE OF FUTURE MODIFICATION. 
* 
*         THIRD LETTER VECTOR 
* 
*                   SET B2 TO THIRD LETTER
*                   JP        TLVEC-1,B2
* 
 TLVEC    BSS    0
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
          ORGEND
 +        EQ     PEND              D
          ORGSTART
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
 +        EQ     ILL               R
          ORGEND
 +        EQ     PBSS              S
 +        SB2    L4VEC-1           T
          EQ     PNL
 +        BX7    X7-X7             U
          EQ     L3.EQU 
          ORGSTART
          DUP    27B,1
 +        EQ     ILL               V - =
          ORGEND
 PEQ      SX4    0400B             SPACE
          EQ     L3.EQ
* 
*         FOURTH LETTER VECTOR
* 
*                   SET B2 TO FOURTH LETTER 
*                   JP        L4VEC-1,B2
* 
 L4VEC    BSS    0
          ORGSTART
 +        EQ     ILL               A
 +        EQ     ILL               B
 +        EQ     ILL               C
 +        EQ     ILL               D
 +        EQ     ILL               E
 +        EQ     ILL               F
 +        EQ     ILL               G
 +        EQ     ILL               H
 +        EQ     ILL               I
 +        EQ     ILL               J
 +        EQ     ILL               K
 +        EQ     ILL               L
 +        EQ     ILL               M
 +        EQ     ILL               N
 +        EQ     ILL               O
 +        EQ     ILL               P
 +        EQ     ILL               Q
          ORGEND
 +        SB2    L5VEC-1           R
          EQ     PNL
          ORGSTART
 +        EQ     ILL               S
 +        EQ     ILL               T
 +        EQ     ILL               U
 +        EQ     ILL               V
 +        EQ     ILL               W
 +        EQ     ILL               X
 +        EQ     ILL               Y
 +        EQ     ILL               Z
* 
*         FIFTH LETTER VECTOR 
* 
*                   SET B2 TO FIFTH LETTER
*                   JP        L5VEC-1,B2
* 
 L5VEC    BSS    0
          DUP    30B,1
 +        EQ     ILL               A - X
          ORGEND
 +        EQ     NOBINPO           Y
          ORGSTART
          DUP    25B,1
 +        EQ     ILL               Z - ,
          ORGEND
 +        EQ     PENTR.            .
          TITLE              INITIALIZATION 
          SPACE  2
 FTNXAS   ENTRY. **          ** MAIN ENTRY/EXIT **
  
*         INITIALIZE PREFIX (77) TABLE. 
  
          SA1    =XPROGNAM   (X1) = PROGRAM UNIT NAME 
          SB1    1
          MX0    L.NAME 
          BX6    X0*X1
          CALL   RTB         REMOVE TRAILING BLANKS 
          SA6    PREFIX+1 
          SB2    6
  
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          SA1    =XLEVEL2    -LEVEL 2 STMT APPEARED- FLAG 
          SA2    PREFIX+7B   HARDWARE DEPENDENCIES WORD 
          ZR     X1,PRF2     IF NO LEVEL 2 STATEMENTS 
          SX6    1RL&1R 
          LX6    48-6*OBJIMULT/OBJIMULT 
          BX7    X2-X6
          NO
          SA7    A2          LCM HARDWARE DEPENDANCY TO PREFIX TABLE
 PRF2     BSS    0
 #DAL     ENDIF 
  
          SA1    =XTL.DATE
          SA2    =XTL.TIME
          SA3    =XTL.CCOP   CONTROL CARD OPTIONS 
          SA4    A3+B1
          SA5    A4+B1
          LX6    X1,B2
          SA6    A6+B1
          LX7    X2,B2
          SA7    A6+B1
          SA1    PROGRAM     DETERMINE PROGRAM UNIT TYPE
          UX0    B3,X1
          NZ     X1,PRF2A    IF NOT BLOCK DATA
          SB3    -B1
 PRF2A    SB3    B3+B1
          SA1    PTYPE+B3 
          BX6    X1 
          SA6    PREFIX+10B 
          SA1    =1H
          BX6    X3 
          LX7    X4 
          IX0    X4-X1
          NZ     X0,PRF3     IF OPTION WORD NON-BLANK 
          BX7    X7-X7       PREFIX TABLE TERMINATOR
 PRF3     SA6    PREFIX+11B 
          IX0    X5-X1
          SA7    A6+B1
          BX6    X5 
          NZ     X0,PRF4     IF OPTION WORD NON-BLANK 
          BX6    X6-X6
 PRF4     SA6    A7+B1
          EQ     INITL
  
  
 PTYPE    DATA   9HBLOCKDATA
          DATA   7HPROGRAM
          DATA   10HSUBROUTINE
          DATA   8HFUNCTION 
 PLUGS    SPACE  4,8
*** 
*         PLUGS TO ACTIVATE THE O LISTING 
* 
          MOVSTART  2 
 RJWRL1   SA6    B7+B2
          SA7    A7-B5
          RJ     WRLIST 
 RJWRL2   SB6    B0 
          SB1    B5 
          RJ     WRLIST 
          MOVEND
          EJECT 
          SPACE  4
**        PIDENT - PROCESS *IDENT* LINE.
* 
*         WHEN AN *IDENT* LINE IS ENCOUNTERED ON -COMPS-, THIS OPEN 
*         SUBROUTINE INITIALIZES -FAX- AND DOES THE FOLLOWING MAIN
*         TASKS --
*                                                                      *
*         1. ALLOCATE AN LGO BUFFER AND SETUP THE FET,                 *
*         2. WRITE OUT LCC STATEMENTS ON LGO IF PRESENT,               *
*         3. SET THE SWITCHES AT NOBINPO AND WRTSW IF THE -O- OPTION   *
*            IS ON,                                                    *
*         4. WRITE A PREFIX TABLE ON LGO,                              *
*         5. SETUP CORGTAB AND LORGTAB, WRITE A PIDL ON LGO,           *
*         6. SCAN THE 2 WORD SYMBOL TABLE MAKING AN ENTR TABLE AND A   *
*            LINK FOUNDATION,                                          *
*         7. SCAN THE GL,AP,VD TABLES REFORMATTING THEM.               *
*                                                                      *
          SPACE  2
 TEMP1    EQU    SCRATCH
 TEMP2    EQU    SCRATCH+1
 TEMP3    EQU    SCRATCH+2
          SPACE  2
          MOVSTART  7 
 LOCNAM   VFD    60/7LSTART.       NAMES OF LOCAL RELOCATION BASES USED 
          VFD    60/7LVARDIM.      IN LORGTAB CONSTRUCTION
          VFD    60/7LENTRY.
          VFD    60/7LCODE. 
          VFD    60/7LDATA. 
          VFD    60/7LDATA..
          VFD    60/7LHOL.
          MOVEND
          SPACE  2
 PIDENT   SA2    =XDIRECT 
          ZR     X2,PID1     IF LCM=D MODE
          SX6    24 
          SA6    XFL         XFILL RELOCATION LENGTH = 24 
          RJ     ALA         ASSIGN LOCAL ADDRESSES TO POINTERS 
 PID1     SA2    =XIOAPLN 
          SA1    =XLWAWORK
          MX7     0 
          IX6    X1-X2
          SA1    =1H
          SA7    IOCTR
          SA6    =XO.IOT
          SA7    BSPFLAG
          SX6    X6-1 
          SA7    AERCNT            ZERO ASSEMBLY ERROR COUNT
          SA6    MEMEND 
          SA7    STOVSIZE 
          SA7    ERRLINE+9
          BX6    X1 
          SETCORE   LINE,ISHIFT    BLANKS TO LINE BUFFER COLS 1-50
          SETCORE   ERRLINE,9      BLANKS TO ERROR MSG BUFFER 
  
*         SET SWITCHS FOR A LISTING 
  
          SA1    OLIST
          SA4    FV.LGO 
          BX3    X1+X4
          CX3    X3 
          ZR     X3,EX.999         EXIT IF B = 0 AND O = 0
          ZR     X1,PID1A          JUMP IF O = 0
          PLUG   AT=WRTSW,FROM=RJWRL1 
          PLUG   AT=NOBINPO,FROM=RJWRL2 
  
*         STOP ASSEMBLY IF FATAL-TO-EXECUTION ERRORS EXIST. 
  
 PID1A    SA1    =XN.FERR 
          SA2    FV.LGO 
          ZR     X1,PID1D          IF NO FATAL-TO-EXECUTION ERRORS
          ZR     X2,EX.999         IF BINARY OUTPUT OPTION OFF (B=0)
          SB6    B0                FLAG FOR NO LIST OF END CARD 
          EQ     EX.12             GO WRITE A PREFIX TABLE ON LGO 
  
*         PRINT THE IDENT CARD
  
 PID1D    SA1    =XOLIST
          ZR     X1,PID1E          IF LIST OPTION OFF 
          NUPAGE
          LISTL  LINE,8            *IDENT* LINE 
          SB5    B1 
 PID1E    RJ     IOCARD            INPUT AND LIST *USEBLK* LINE 
  
*         SKIP *LCC* DIRECTIVES.
  
 PID2     RJ     IOCARD            INPUT AND LIST CARD
          SA1    ILINE
          SA2    =6L  LCC 
          MX0    36 
          BX3    X0*X1
          IX4    X3-X2
          NZ     X4,PID2D          IF NOT AN LCC CARD 
          EQ     PID2 
  
*         SKIP OVER ANY LDSET DIRECTIVES
  
          MOVSTART  4 
 PID2C    RJ     IOCARD 
          SA1    ILINE
  
 PID2D    SA2    =10H  LDSET
          IX4    X1-X2
          NZ     X4,PID3           IF NOT A LDSET CARD
          EQ     PID2C
          MOVEND
  
*         WRITE PREFIX (77) AND LDSET (70) TABLES TO BINARY OUTPUT FILE.
  
 PID3     SA1    FV.LGO 
          ZR     X1,PID3A          IF BINARY OUTPUT OPTION OFF (B=0)
          WRITEW F.LGO,PREFIX,L.PRFX
          SA2    PROGRAM
          ZR     X2,PID3A    IF BLOCK DATA, SKIP LDSET TABLE
          SA2    MEMSTRT
          SA1    LDUSE
          SB6    X2          (B6) = FWA 7000 TABLE
          SB2    B6+B1       (B2) = FWA *LIB* SUBTABLE
          SA1    X1 
          SB3    B0          (B3) = LENGTH SUBTABLE 
 PID3.2   BX6    X1 
          SA1    A1+B1
          SB3    B3+B1
          SA6    B2+B3
          NZ     X1,PID3.2   IF NOT END OF SUBTABLE 
          SX7    10BS12+B3   FORM *LIB* SUBTABLE HEADER 
          LX7    36 
          SA7    B2 
          SA1    =XPMDFLAG
          ZR     X1,PID3.2B  IF PMDMP PRESET NOT REQUIRED 
          SA1    PMDUSE-1    FWA-1 OF PMDMP MAP AND PRESET TABLES 
 PID3.2A  SA1    A1+B1                                                  000370
          ZR     X1,PID3.2B   IF END OF TABLES                          000380
          BX6    X1                                                     000390
          SA6    A6+B1                                                  000400
          EQ     PID3.2A                                                000410
                                                                        000420
 PID3.2B  SA1    =XCO.STA                                               000430
          ZR     X1,PID3.5   IF STATIC LOAD OPTION NOT SELECTED 
          SA1    =XSTLTAB-1 
          SB2    A6+B1       (B2) = FWA *USE* SUBTABLE
          SB3    B0 
          MX7    -7*6 
 PID3.3   SA1    A1+B1
          BX6    -X7*X1 
          ZR     X1,PID3.4   IF END OF TABLE
          PL     X1,PID3.3   IF ENTRY NOT SELECTED
          LX6    18 
          SB3    B3+B1
          SA6    B2+B3
          EQ     PID3.3 
  
 PID3.4   ZR     B3,PID3.5   IF NO *USE* ENTRIES SELECTED 
          SX7    16BS12+B3   FORM *USE* SUBTABLE HEADER 
          LX7    36 
          SA7    B2 
 PID3.5   SX2    A6-B6       (X2) = NUMBER OF 7000 TABLE ENTRIES
          SB7    X2+B1       (B7) = LENGTH OF 7000 TABLE
          LX2    36 
          MX7    3           TABLE HEADER = 7000BS48
          BX7    X7+X2
          SA7    B6 
          WRITEW F.LGO,B6,B7 7000 TABLE TO BINARY OUTPUT FILE 
 PID3A    RJ     SKIP2
  
*         BEGIN FORMING PIDL (34) TABLE AT TOP OF FREE MEMORY.
  
          SA1    =XN.COM           NUMBER OF COMMON BLOCKS
          SA2    MEMEND 
          SX3    3400B
          SX1    X1+B1       (X1) = PIDL WORD COUNT 
          LX3    12-0 
          IX6    X3+X1
          SX1    X1+B1       (X1) = PIDL LENGTH 
          LX6    48-12
          IX2    X2-X1
          SA6    X2          PIDL HEADER OUT
          LX1    18 
          BX7    X1+X2
          SA7    TEMP1       TEMP SAVE  24/0,18/PIDL LEN,18/PIDL FWA
          SA1    PREFIX+1    (X1) = PROG UNIT NAME
          SA2    L.PROG 
          BX6    X1+X2
          SA6    A6+B1       42/PROG UNIT NAME, 18/PROG LEN 
  
*         SET UP CORGTAB, MOVE BLOCK NAMES AND LENGTHS TO THE PIDL
*         CALL BUILDOT TO MAKE A CORGTAB ENTRY
  
          SB1    B5+B5             ORGTAB ORDINAL, RB CODE, AND PIDL ORD
          SA2    MEMSTRT           FWA CORGTAB
          SX7    B1 
          SA1    =6LCOMMON
          SA7    SWC               WORD COUNT OF LINE 
          BX6    X1 
          SB6    X2                B6 ALWAYS CONTAINS FWA NEXT 22 WORD E
          BX7    X2 
          SA6    ILINE+1           BLOCK TYPE TO BE PRINTED 
          SA7    CORGTAB           SET POINTER TO CORGTAB 
 PID.61   SA1    =XORGTAB-2+B1
          SA5    TEMP1             PIDL LENGTH AND FWA
          ZR     X1,PID.70         IF ORGTAB ENTRY=0 THEN EXIT
          SA2    =7L
          MX0    42 
          LX6    X1,B0
          BX3    X0*X1
          IX3    X3-X2
          ZR     X3,PID.62         IF BLANK COMMON STORE DIRECTLY INTO T
          RJ     RTB
  
 PID.62   SX2    X6-0 
          MX4    -17
          SX5    X5          (X5) = PIDL FWA
          PL     X2,PID.621        IF NOT AN ECS COMMON BLOCK 
          BX2    -X4*X6 
          MX7    -3          -7 
          IX2    X2-X7
          AX2    3           (LENGTH+7)/8 
          BX7    X4*X6
          IX6    X2+X7       ECS BIT, NAME, AND LENGTH IN ECS 
 PID.621  BX2    -X4*X1            17-BIT LENGTH FIELD
          SB2    B0                ORGC 
          SA6    X5+B1             BLOCK NAME AND LENGTH TO PIDL
          BX1    X0*X1             BLOCK NAME 
          NZ     X3,PID.63         IF BLANK COMMON SET NAME TO // 
          SA1    =7L//
 PID.63   SB3    B1+B5             RELOCATION BASE CODE 
          RJ     BUILDOT           MAKE ORGTAB ENTRY AND PRINT
          EQ     PID.61 
  
*         TERMINATE CORGTAB.  WRITE PIDL TO BINARY OUTPUT FILE. 
  
 PID.70   SA1    TEMP1
          SA2    FV.LGO 
          SB1    1
          BX6    X6-X6
          SX7    B6+B1             FWA LOCAL ORGTAB 
          SA6    B6                TERMINATING ZERO TO CORGTAB
          SB6    X1                PIDL FWA 
          SA7    LORGTAB
          ZR     X2,PID.701        IF BINARY OUTPUT OPTION OFF (B=0)
          AX1    18 
          SB7    X1                PIDL LENGTH
          WRITEW F.LGO,B6,B7       PIDL (34) TABLE TO LGO FILE
  
*         INITIALIZE NORMAL RELOCATION BASES IN ORGTAB. 
  
 PID.701  SA1    =L*LOCAL*
          SA2    LORGTAB
          BX6    X1 
          SB5    B1                (B5) = 1 
          SA6    ILINE+1           *LOCAL* BLOCK TYPE TO LISTING BUFFER 
          SX7    X2+5 
          SA7    TEXT.ADD          INITIALIZE TO START. 
          SX6    X7+4*22
          SA6    DATA.TXT          FWA DATA. TEXT TABLE 
          SB1    B0                (B1) = BLOCK COUNTER 
          SB2    B0+               (B2) = PROGRAM LENGTH ACCUMULATOR
          SB6    X2                (B6) = BLOCK ENTRY POINTER 
 PID.71   SA1    LOCNAM+B1         (X1) = BLOCK NAME
          SA2    ORGTAB+M.NCB+1+B1 (X2) = BLOCK LENGTH
          SB3    1                 (B3) = RELOC BASE CODE = *PROGRAM* 
          CALL   BUILDOT
          SB4    N.LRB
          LT     B1,B4,PID.71      IF MORE BLOCKS TO INITIALIZE 
  
* CHECK SYMTAB FOR FORMAL PARAMETERS, IF PRESENT THEN MAKE LORGTAB
* ENTRIES AND CONVERT THE RA FIELD IN THE 2 WORD SYMTAB TO A REL. ADD.
  
          SA5    SYM1 
          SB1    N.LRB             B1 = RB CODE 
          SX5    X5-4 
  
 PID8     SA4    X5                WORD A 
          SA5    A4-B5             WORD B 
          MX0    L.NAME 
          BX1    X0*X4             X1 = NAME
          LX4    59-P.FP
          PL     X4,PID9           IF NOT A F.P.
  
          BX2    X5 
          AX2    P.RA 
          MX0    L.RA 
          SX2    X2                BLOCK LENGTH 
          LX0    L.RA+P.RA
          SX3    B2                CURRENT PROG ADDR
          BX5    -X0*X5 
          LX3    P.RA 
          BX6    X3+X5             INSTALL PROG RELATIVE ADDR 
          SA6    A5 
          SX7    A5-B5
          SB3    B5                RB = 1 ( PROG RELATIVE ) 
          SA7    TEMP1
          RJ     BUILDOT           SET UP ORG TABLE 
          SA5    TEMP1
          EQ     PID8 
  
*         TERMINATE LORGTAB AND UPDATE MEMSTRT
  
 PID9     MX6    0
          SA6    B6                TERMINATE LORGTAB WITH A ZERO WORD 
          SX7    B6+B5
          SA7    MEMSTRT
          RJ     SKIP2
  
*         CHANGE ENTRIES IN TSS FROM SYMTAB ADDRESS"S TO THEIR
*         PROGRAM RELATIVE ADDRESS"S
  
          SA5    SYM1 
          MX0    L.NAME 
          SA0    X5                A0 = SYM1
  
          SB1    O.TSS
          SB2    L.TSS             LWA+1
 PID9A    SA1    B1 
          SB1    B1+B5
          ZR     X1,PID9B          IF SYMBOL NOT IN SYMTAB
          LX3    B5,X1
          SB3    X3+B5             2*ORD+1
          SA2    A0-B3             WORD B 
          AX2    P.RA 
          SX6    X2 
          SA6    A1 
 PID9B    LT     B1,B2,PID9A
  
*         FORM ENTR (36) TABLE AND WRITE IT TO BINARY OUTPUT FILE.
  
          SA2    L.ENTR 
          SA1    O.ENTR 
          ZR     X2,PID11          IF NO ENTRY POINTS 
          SA4    MEMSTRT
          SA3    MEMEND 
          LX5    X2,B5             ENTR TABLE LENGTH (NOT INCL HEADER)
          SB1    X1 
          SB2    B1+X2             LWA+1 OF ENTR TABLE IN HIGH CORE 
          IX2    X3-X4             WORKING STORAGE LENGTH 
          SX7    36B               LOADER CODE - ENTR TABLE 
          IX6    X5-X2
          MX3    -L.RL-L.RA 
          PL     X6,STOVER         IF NOT ENOUGH WORKING STORAGE
          LX7    54-36
          BX6    X7+X5
          LX6    36 
          SB6    X4+               (B6) = TABLE FWA 
          SA6    X4                TABLE HEADER TO WSA
 PID10    SA1    B1                ENTRY POINT ORD
          LX4    B5,X1
          SB4    X4 
          SA1    A0-B4             WORD A 
          SA2    A1-B5             WORD B 
          BX6    X0*X1             NAME 
          RJ     RTB
          AX2    P.RA 
          SA6    A6+B5
          SB1    B1+B5
          BX6    -X3*X2            RL AND RA
          SA6    A6+B5
          LT     B1,B2,PID10
          SB7    A6-B6
          SA1    FV.LGO 
          SB1    1
          ZR     X1,PID10A         IF BINARY OUTPUT OPTION OFF (B=0)
          SB7    B7+B1             (B7) = TABLE LENGTH
          WRITEW F.LGO,B6,B7       ENTR (36) TABLE TO BINARY OUTPUT FILE
 PID10A   SA1    SYM1 
          SB5    B1 
          SA0    X1                (A0) = INVERTED FWA SYMBOL TABLE 
  
*         BUILD LINK AND EXTERNAL NAME TABLES FROM EXT TABLE
  
 PID11    SA1    O.EXT
          SA2    L.EXT
          SB1    X1 
          SB2    B1+X2
          SA3    MEMSTRT
          SA4    MEMEND 
          BX6    X3 
          SB6    X3 
          SA6    LINKTAB
  
          IX3    X2+X3
          IX5    X3-X4             F - L
          PL     X5,STOVER         IF NOT ENOUGH ROOM 
  
          MX7    0
          SA7    X3                CLEAR LWA+1 OF LINKTAB 
          SA7    RBTEMP 
          SX6    X3+B5
          MX0    L.NAME 
          SA6    FREEMEM           SET FWA FOR CHAIN ACCUMULATION 
          ZR     X2,PID20          IF NO EXTERNALS
  
 PID12    SA4    B1                2*SYMORD 
          SB4    X4 
          SA1    A0-B4             WORD A 
          SA2    A1-B5             WORD B 
          BX6    X0*X1             NAME 
          SX5    A2 
          IX7    X6+X5             42/7LNAME,18/LOCF(WORD B)
          SA7    B1                EXT TAB ENTRY
          SB1    B1+B5
          RJ     RTB
          SA6    B6                STORE IN LINK TAB
          SX5    B6 
          LX2    -P.RA
          BX2    X0*X2
          BX7    X2+X5       STORE LINKTAB ADDRESS IN WORDB 
          LX7    P.RA 
          SA7    A2 
          SB6    B6+B5
          LT     B1,B2,PID12
          MX6    0
          SA6    B6                ZERO WORD TO TERMINATE LINKTAB 
  
*         PRINT NAMES OF EXTERNALS
  
          SA3    OLIST
          ZR     X3,PID20          IF O = 0 
          SA1    =18L   EXTERNALS 
          SB1    1
          SA2    A1+B5
          BX6    X1 
          LX7    X2 
          SA6    ILINE-2
          SA7    A6+B5
          LISTL  LINE,ISHIFT
          SA1    O.EXT
          SA2    L.EXT
 PID14    SB2    X1 
          SB3    B2+X2             LWA+1
          SB7    ISHIFT-2          (B7) = LINE LENGTH 
          SA3    SPACES+3          3R 
          SB4    10                WORD LIMIT 
 PID15    SA1    B2 
          MX0    L.NAME 
          SB2    B2+B1
          BX2    X0*X1             NAME 
          IX6    X2+X3
          SB7    B7+B1             LENGTH + 1 
          SA6    LINE-1+B7
          GE     B7,B4,PID16       IF LINE FULL 
          LT     B2,B3,PID15       IF MORE NAMES TO GO
 PID16    MX5    60-12
          BX6    X5*X6
          SA6    A6 
          SX6    B2 
          SX7    B3-B2
          SA6    TEMP1
          SA7    A6+B1
          LISTL  LINE,B7
          SA2    TEMP1+1
          SB5    B1 
          SA1    A2-B1
          NZ     X2,PID14          IF MORE TO GO
          RJ     SKIP2
          SA1    =10H 
          BX6    X1 
          SA6    ILINE-2
          SA6    A6+B1
  
*         SET UP GL/AP RELOCATION SKELETON. 
  
 PID20    SA1    PROGRAM
          SB5    1
          ZR     X1,INITL        IF A BLOCK DATA PROGRAM
          SA5    WB.LAB 
          SA4    O.LRB+3           FWA OF CODE. 
          LX4    P.RA 
          BX6    X4+X5
          SA6    GLAPR
  
          SA1    =10H 
          BX6    X1 
          SETCORE LINE,ISHIFT 
  
          SA1    PROGRAM
          UX0    B1,X1
          NZ     B1,INITL          IF A SUBPROGRAM
  
*         PROCESS PROGRAM 
  
          SA1    N.FILES
          ZR     X1,PID25          IF NO FILES
          BX6    -X1
          SA6    TEMP1             TEMP1 = -N.FILES 
          SA6    A6+B5
  
 PID22    RJ     RCARD             INPUT A CARD 
          SA2    ILINE
          SA3    =10H  FIL-RM 
          BX6    X2-X3
          LX6    -4*6 
          AX6    1*6         IGNORE *C* OR *7* IN COLUMN 6
          ZR     X6,PID23    IF *FIL-RM* MACRO
          SA1    SWC         ASSUME *FEQU* MACRO - LIST AND SKIP IT 
          LISTER  LINE,ISHIFT+X1
          EQ     PID24
 PID23    RJ     PFILE
  
 PID24    SA1    TEMP1
          SX6    X1+B5
          SA6    A1 
          NZ     X6,PID22 
  
  
 PID25    SA1    =XOT.RM
          NZ     X1,PID25.4  IF 7RM OBJECT MODE 
  
*         PROCESS *LIBLNK* MACROS.
  
          RJ     IOCARD      READ AND LIST *LIBLNK. BSS 0B* 
          RJ     RCARD       READ *  LIBLNK P1,..* MACRO
          SA1    =8RFILES.   FORM  12/2000B+NR FILES, 48/*FILES.* ADDR
          SB7    PID25.2     (B7) = *SYMBOL* RETURN ADDR
          EQ     SYMBOL 
  
 PID25.2  EQ     *+4S15      COMPILER ERROR IF *LIBLNK.* NOT FOUND
  
          SA1    =XN.FILES
          AX2    P.RA 
          SB2    X1 
          MX0    -L.RA
          BX2    -X0*X2 
          PX4    X2,B2
          WR1WD 
          RL=    L
  
          SA1    =XCO.STA    FORM  1/STATIC BIT, 59/PRINT LIMIT 
          SA2    =XPLIMIT 
          BX4    X1+X2
          WR1WD 
  
*            OUTPUT A POINTER TO, AND, OUR WEAK EXTERNAL TABLE, IF
*         WE HAVE HERE A MAIN PROGRAM WITHOUT FILES AND STATIC
*         MODE IS SELECTED. 
  
          SA1    CO.STA 
          ZR     X1,PID25.3  IF STATIC MODE IS NOT SELECTED 
          SA1    N.FILES
          NZ     X1,PID25.3  IF MAIN PROGRAM WITH FILES 
          SYMBOL =8RWXTTAB. 
 +        EQ     *+1S17      COMPILER ERROR IF NOT FOUND
          AX2    P.RA 
          MX0    -L.RA
          BX4    -X0*X2      ISOLATE ADDRESS
          BX6    X4 
          PX4    B5,X4
          SA6    TEMP3
          WR1WD              POINTER TO WEAK EXTERNAL TABLE 
          RL=    L           LOWER RELOCATION 
  
          MX4    0
          WR1WD              APLIST TERMINATOR
  
*         NOW OUTPUT THE WEAK EXTERNAL AND XLINK TABLES.
  
          SX6    L.STL       NUMBER OF WORDS IN W.EXT. TABLE
  
 PID25.33 SA6    TEMP1       LOOP FOR W.EXT. TABLE
          MX4    0
          WR1WD 
          SA1    TEMP1
          SX6    X1-1 
          NZ     X6,PID25.33 IF MORE TO GO
  
*         FILL IN *XLINK* CORE ADDRESSES. 
  
          SA1    TEMP3       GET CORE ADDRESS OF *XLINK* TABLE
          SA2    S.WEXT-1    FIRST WORD OF *XLINK* TO STUFF 
          SB3    N.STL       NUMBER OF ENTRIES TO STUFF 
          SX1    X1-1 
          SB4    3           INCREMENT BETWEEN ENTRIES
          MX3    1           FLIP FLOP
          SX4    B5 
          LX1    30          POSITION ADDRESS 
          LX4    30          ADDRESS INCREMENT
  
 PID25.36 SA2    A2+B4       NEXT ENTRY TO STUFF
          LX3    30          FLIP THE FLOP
          MI     X3,PID25.38 IF WE DO NOT INCREMENT ADDRESS THIS TIME 
          IX1    X1+X4       INCREMENT ADDRESS
  
 PID25.38 BX6    X1+X2
          SA6    A2          STUFF
          SB3    B3-B5
          NZ     B3,PID25.36 IF MORE TO STUFF 
  
          WRITEW F.LGO,S.WEXT,L.WEXT
          EQ     PID25.4
  
 PID25.3  MX4    0           APLIST TERMINATOR
          WR1WD 
  
 PID25.4  RJ     IOCARD      READ AND LIST *FILES. BSS 0B*
          SA1    N.FILES
          ZR     X1,PID30          IF NO FILES
  
*         INPUT AND PROCESS FLINK MACRO CALLS 
  
 PID26    RJ     RCARD             INPUT CARD 
          BX1    X5 
          AX1    12 
          SB7    PID26A 
          EQ     SYMBOL 
  
 PID26A   EQ     *+1S17            COMPILER ERROR IF SYMBOL NOT FOUND 
  
          MX0    -L.RA
          AX2    P.RA 
          BX3    -X0*X2            RA 
          SX2    1R"C"
          RJ     RSC               REMOVE # 
          AX6    B7,X6
          LX5    B7,X6             REMOVE BLANK FILL
          BX4    X5+X3             42/0L_NAME,18/LOCF(FET)
          WR1WD                    TO THE LGO FILE
          RL=    L                 ADJUST RELOCATION WORD 
  
          SA1    TEMP1+1
          SX6    X1+B5
          SA6    A1 
          NZ     X6,PID26 
  
 PID30    RJ     RCARD       READ 0 APL TERMIN (CRM) OR DATA -PL (7RM)
          SA1    =XOT.RM
          SA2    =XPLIMIT 
          MX4    0           PRESET 0 APL TERMINATOR
          ZR     X1,PID30.2  IF CRM OBJECT MODE 
          BX4    -X2         SET -(PRINT LIMIT) 
 PID30.2  WR1WD 
          EQ     INITL
 ALA      SPACE  3,24 
**        ALA - ASSIGN LOCAL ADDRESSES TO LCM POINTER WORDS.
*         IN INDIRECT (LCM=I) MODE, LCM SYMBOLS REPRESENT SCM POINTER 
*         CELLS IN GENERATED CODE.  FOR FAX, THE RL, RB, AND RA OF EACH 
*         LCM SYMBOL MUST NOW BE CHANGED TO REFLECT THAT.  PRIOR TO THIS
*         THIS INFORMATION REFLECTED THE SYMBOL/S USER-DEFINED LCM
*         RESIDENCY.   THIS TRANSFORMATION MUST BE DEFERED UNTIL FAX
*         SO THAT THE REFERENCE MAP WILL CONTAIN MEANINGFUL (LCM) 
*         ADDRESSES.
  
 ALA      ROUTINE 
          SA2    =XSDATA. 
          MI     X2,ALA      IF NO LCM POINTER VECTOR 
          SB1    1
          SA5    =XST.             ORDINAL OF ST. 
          SA4    =XSYMORD          N.SYMBOLS + 1
          SA3    SYM1 
          LX5    1                 2*ORDINAL OF ST. 
          IX4    X4+X4             2*(N.SYMBOLS + 1)
          SB6    X5 
          SA0    X3-1 
          SB7    X4 
          SA2    SDATA.            SAVED DATA. VALUE
          SA4    O.LRB+4           FWA OF DATA. BLOCK 
          IX2    X2+X4
          LX2    P.RA 
          SA1    WBDATA.           WORD B FOR DATA. BLOCK 
          BX1    X1+X2
          MX7    60-L.ADF          MASK FOR ADDRESS DEFINITION FIELD
          LX7    P.ADF
          SX2    B1 
          LX2    P.RA 
  
*         SEARCH THE SYMBOL TABLE FOR LEVEL 2 OR 2 AND 3 VARIABLES
  
 ALA1     SA5    A0-B6             WORD B 
          GE     B6,B7,ALA         IF END OF TABLE
          BX6    X5 
          LX5    59-P.LCM 
          SB6    B6+2              ADVANCE TO NEXT SYMBOL 
          PL     X5,ALA1     IF SYMBOL NOT LCM
          SX0    10B-T.LAB
          ERRMI  10B-T.LAB   TEST RELIES ON OVERFLOW
          LX5    1+P.LCM
          LX0    P.TYP
          IX3    X0+X5
          MI     X3,ALA1     IF TYPE[WORDB] .GE. T.LAB
          BX3    X7*X6             CLEAR ADDRESS FIELD
          IX6    X3+X1             INSERT DATA. FIELD 
          SA6    A5 
          IX1    X1+X2             DATA. = DATA. + 1
          EQ     ALA1 
          EJECT 
*** 
*         IOCARD - INPUT AND LIST CARD
* 
 IOCARD   ENTRY. *           ** ENTRY/EXIT ** 
          RJ     RCARD
          SA1    SWC
          LISTER  LINE,ISHIFT+X1
          SA1    ILINE+1
          EQ     IOCARD 
          SPACE  3
*** 
*         RSC - REMOVE SPECIAL CHARACTER FROM NAME
* 
*         ON ENTRY: 
*                X1 = 7L_NAME 
*                X2 = SPECIAL CHARACTER TO BE REMOVED ( $ OR # )
* 
*         ON EXIT:  
*                X6 = NAME WITH SPECIAL CHAR REMOVED
*                B7 = 60-BIT COUNT FOR LENGTH OF NAME 
* 
          MOVSTART  7 
 RSC
          SB7    12 
          MX0    60-6 
 RSC2     SB7    B7+6 
          AX6    B7,X1
          BX7    -X0*X6 
          SX4    X7-1R
          ZR     X4,RSC2     IF A BLANK, LOOP 
          IX7    X7-X2
          BX6    X1 
          NZ     X7,RSC            IF NOT SPECIAL 
          SX2    X2-1R
          LX2    B7,X2
          IX6    X6-X2             CHANGE LAST CHAR TO BLANK
          SB7    B7+6 
          EQ     RSC
          MOVEND
          EJECT 
*** 
*         PTRACE - PROCESS "TRACE" MACRO CALL 
* 
          MOVSTART  12B 
 PTRACE   BSS    0
          SA1    =XPROGNAM         (X1) = PROGRAM UNIT NAME, 7H FORMAT
          SX2    1R$
          RJ     RSC               REMOVE ANY SPECIAL CHAR
          SA3    SYM1 
          SA1    X3-3              WORD B OF ORDINAL 1
          AX1    P.RA 
          SX3    X1                RELOCATION ADDRESS 
 PTRACE1  BX4    X6+X3             42/7L_NAME,18/LOCF(ENTRY.) OR 0
          WR1WD                    WRITE WORD TO LGO FILE 
          RL=    L                 ADD RELOCATION BYTE
          SA1    =XTEMPA0.
          ZR     X1,INITL          IF NO FPS OR RETURNS 
  
          MX4    0                 A ZERO WORD FOR TEMPA0.
          WR1WD  ,INITL            TO THE LGO FILE
          MOVEND
 PPENTRY  SPACE  4,8
**        PPENTRY - PROCESS *PENTRY* MACRO. 
* 
  
 PPENTRY  SA2    PROGRAM
          SA1    =XFUNTYPE
          UX0    B1,X2
          ZR     B1,PPE4           IF MAIN PROGRAM
          ZR     X1,PPE2           IF NOT A FUNCTION
          AX1    1
          ZR     X1,PPE1           IF SINGLE PRECISION
          SA5    =XVALUE. 
          SA4    VAL2 
          LX5    30 
          IX4    X5+X4
          WR1WD 
          RL=    U
 PPE1     SA4    VAL1 
          SA5    VALUE. 
          LX5    30 
          IX4    X5+X4
          WR1WD 
          RL=    U
  
 PPE2     SA1    =XTEMPA0.
          ZR     X1,PPE3           IF NO FPS OR RETURNS, THEN NO NEED TO
*                                    RESTORE *TEMPA0.*
          SA5    RSTRA0 
          LX1    30 
          IX4    X1+X5
          WR1WD 
          RL=    U
  
 PPE3     SA1    =XCO.ER
          ZR     X1,PPE3A    IF ER = 0
          CALL   OTR
 PPE3A    SA1    ENTRY. 
          SA4    PENTRY            ENTRY POINT CODE 
          LX1    30 
          BX4    X1+X4
          WR1WD                    WRITE WORD TO LGO FILE 
          RL=    U                 ADJUST RELOCATION
  
          SA1    =XTEMPA0.
          ZR     X1,INITL          IF NO FPS OR RETURNS, THEN NO NEED TO
*                                    RESTORE *TEMPA0.*
  
          WR1WD  SAVA0             SAVE A0 CODE TO LGO FILE 
          RL=    L                 ADJUST RELOCATION BYTE 
          EQ     INITL
  
 PPE4     SA1    =XCO.ER
          ZR     X1,PPE4A    IF ER = 0
          SA1    =XN.FILES
          SA2    L.PROGP
          SX3    1
          IX4    X1+X3
          IX6    X2-X4
          SA6    A2 
          CALL   OTR
          EQ     INITL
  
 PPE4A    SA1    SWC
          LISTER LINE,ISHIFT+X1 
          EQ     INITL
  
  
  
*         CODE SKELETONS FOR ENTRY/EXIT LINE. 
  
 VAL2     SA5    1                 VALUE.+1 
          BX7    X5 
 VAL1     SA4    0                 VALUE. 
          BX6    X4 
 RSTRA0   SA3    0                 TEMPA0.
          SA0    X3+0 
  
 PENTRY   EQ     4S15 
 SAVA0    SX6    A0 
          SA0    A1 
          SA6    1                 TEMPA0.
 OTR      JP     *+1S17 
          SA1    TRACE. 
          SA4    FTNRPV 
          SA2    L.PROGP
          MX0    -18
          BX3    -X2
          BX5    -X0*X3 
          BX4    X1+X4
          LX5    30 
          BX4    X4+X5
          WR1WD              WRITE ONE WORD TO LGO
          RL=    L           ADJUST RELOCATION
          EQ     OTR
  
 FTNRPV   SB0    B2+0        (LEN.) 
          SB0    B2+0        (TRACE.) 
          TITLE     INITIALIZATION SUBROUTINES
          EJECT 
*** 
*                                                                      *
* BUILDOT-SUBROUTINE TO BUILD A 22 WORD CORGTAB OR LORGTAB ENTRY AND   *
*         PRINT THE BLOCK NAME, BASE ADDRESS AND LENGTH.               *
*                                                                      *
*         THE 22 WORD ORGTAB IS USED TO KEEP NAME, NFLAG(FORCE UPPER ON*
*         THE NEXT WORD IF GTR 0), ORG COUNTER, RELOCATION BASE CODE,  *
*         POSITION COUNTER, AND PARTIALLY FILLED TEXT TABLES FOR EACH  *
*         RELOCATION BASE.                                             *
*                                                                      *
*         CALLING SEQUENCE-                                            *
*                   B2.= ORGC                                          *
*                   B3.= RELOCATION BASE CODE                          *
*                   B6.= FWA OF NEXT 22 WORD ENTRY                     *
*                   X1.= BLOCK NAME                                    *
*                   X2.= BLOCK LENGTH                                  *
*                                                                      *
*         ON EXIT-                                                     *
*                   IN THE 22 WORD ENTRY,                              *
*                   WORD 1    BITS 18-59/NAME (LEFT ADJ., BLANK FILL)  *
*                             BITS 0 -17/ZERO                          *
*                   WORD 2    NFLAG - ZERO                             *
*                   WORD 3    BITS 24-59/UNUSED                        *
*                             BITS 18-23/RB CODE                       *
*                             BITS 0 -17/ORGC                          *
*                   WORD 4    BITS 18-59/UNUSED                        *
*                             BITS 0 -17/POSC                          *
*                   WORD 5    BITS 18-59/UNUSED                        *
*                             BITS 0 -17/TEXT TABLE ORDINAL (2)        *
*                   WORD 6    TEXT ID WORD                             *
*                             BITS 54-59/40B                           *
*                             BITS 24-53/ZERO                          *
*                             BITS 18-23/RB CODE                       *
*                             BITS 0 -17/ORGC                          *
*                   WORD 7    RELOCATION BYTE WORD - ZERO              *
*                   WORD 8    FIRST TEXT WORD - ZERO                   *
*                   WORDS 9                                            *
*                      TO 22  REMAINDER OF TEXT TABLE - UNINITIALIZED  *
*                                                                      *
*         ALSO-                                                        *
*                   B1.= B1+1                                          *
*                   B2.= B2+BLOCK LENGTH(X2)                           *
*                   B6.= B6+22                                         *
*                                                                      *
          SPACE  2
 B1TEMP   EQU    SCRATCH+3
          SPACE  2
 BUILDOT  BSS    1
          SX3    B2 
          LX6    X1,B0
          SA4    =3R
          BX7    X7-X7
          SX5    B3 
          SA7    B6+B5             ZERO TO OT2
          LX5    18 
          SA6    B6                BLOCK NAME TO OT1
          BX7    X3+X5
          IX6    X1+X4
          SA7    A7+B5             RB+BA TO OT3 
          MX0    1
          SA6    ILINE             BLOCK NAME TO PRINT BUFFER 
          BX7    X0+X7
          SX6    B5+B5
          MX0    57 
          SA6    A7+2              TABC.=2 IN OT5 
          SA7    A6+B5             TEXT ID WORD IN OT6
          SB4    18 
          BX7    X7-X7
          SB7    X6+B5
          LX0    15 
          SX6    60 
          SA7    A7+B5             RB WORD.= 0 IN OT7 
          SA6    A6-B5             POSC.= 60 IN OT4 
          SA7    A7+B5             1ST TEXT WORD.=0 IN OT8
          BX6    X6-X6
 BOT.1    BX1    -X0*X2            CONVERT BASE ADDRESS AND LENGTH TO DI
          SB4    B4-B7             AND STORE THEM IN LINE BUFFER. 
          LX1    X1,B4
          BX4    -X0*X3 
          IX6    X1+X6
          LX4    X4,B4
          BX7    X4+X7
          AX0    3
          NZ     B4,BOT.1 
          SA5       =10H    000000
          IX7    X5+X7
          IX6    X5+X6
          NO
          LX6    12 
          SA7    ILINE-2
          SA6    A7+B5
          SX6    B1 
          SX7    B2+X2
          SA6    B1TEMP            SAVE B1,B2,B6
          SA7    A6+B5
          SX6    B6+22
          SA6    A7+B5
          LISTER  LINE,ISHIFT+2    PRINT OUT THE BLOCK NAME 
          SA1    B1TEMP            RESTORE B1,B2,B6 
          SA2    A1+B5
          SB1    X1+B5
          SA3    A2+B5
          SB2    X2 
          SB6    X3 
          EQ     BUILDOT
          TITLE              SCANNER
 PCOMM    BX6    X4 
          SA6    NFLAG             RESET NFLAG TO RESET FFLAG IN INITL
 NOBINPO  NO                       CHANGED TO RJ  WRLIST IF 
          NO                       O OPTION IS SELECTED 
          SPACE  3
 INITL    SB1    1
          READC  F.CMPS,ILINE,LINESIZE-ISHIFT 
          NZ     X1,NOEND    IF -COMPS- PREMATURELY EMPTY, ERROR
          SA5    ILINE       (X5) = FIRST WORD OF INPUT LINE
          SA4    NFLAG
          MX0    -6          (X0) = 1-CHAR MASK 
          SB5    B1          (B5) = 1 
          SX7    B6-ILINE    (X7) = LINE LENGTH (WORDS) 
          SB4    54 
          SB6    6
          BX6    X6-X6
          SB7    B4 
          GCH    X1 
          SB1    1R 
          SA6    A4          (NFLAG) = 0
          SB2    X1 
          SA7    SWC
          JP     COL1VEC+B2  TO OPCODE VECTOR TABLE 
          SPACE  2
 BLANK    BX6    X4                FFLAG.=NFLAG 
          SB4    B4-B6
          SA6    FFLAG
* 
*         SCAN TO OPCODE
* 
 OCSCAN   GCH    X2                PUT NEXT CHARACTER INTO B2 
          SB2    X2 
          CWD 
          NE     B2,B1,OCSCAN2     IF NOT BLANK 
          GCH    X2                PUT NEXT CHARACTER INTO B2 
          SB2    X2 
          CWD 
          EQ     B2,B1,OCSCAN      GO LOOK AT NEXT CHARACTER
 OCSCAN2  GCH    X2                PUT NEXT CHARACTER INTO B3 
          SB3    X2 
          CWD 
          JP     FLVEC-1+B2        TO OPCODE VECTOR TABLE 
* 
*         PROCESS FORCING CHARACTER 
* 
          MOVSTART  4B
 PFC      SA6    FFLAG
          SB4    B4-B6
          GCH    X3                PUT FIRST CHARACTER OF OPCODE INTO B2
          SB2    X3 
          GCH    X3                PUT SECOND CHARACTER OF OPCODE INTO B
          SB3    X3 
          JP     FLVEC-1+B2        JUMP INTO NEST OF VECTORS
          MOVEND
* 
*         PROCESS LABEL 
* 
          MOVSTART  13B 
 PLABEL   SX7    B5                FORCE UPPER
          SA7    FFLAG
          SB2    B6 
          RJ     PACKID            GO STRIP OFF LABEL 
          BX6    X1 
          SA6    ALABEL 
          AX1    42 
          SX2    X1-1R] 
          NZ     X2,OCSCAN   IF NOT AN ]IO LABEL
          SA3    IOCTR
          SX6    X3+B5             BUMP IO APLIST COUNTER 
           SA6   A3 
          SA2    =XWB.FMT          RL = 1, RB = DATA. 
 .DATA.   EQU    4*22+2            ORGC WORD FOR DATA.
          SA1    LORGTAB
          SA4    X1+.DATA.
          SA1    A4+B5             POSC 
          NZ     X1,PLAB.1         IF A PART WORD LEFT TO GO
          SX4    X4+B5             ADVANCE TO NEXT WORD 
 PLAB.1   SX6    X4 
          LX6    P.RA 
          BX6    X2+X6             COMBINE RL, RA, AND RB FIELDS
          SA1    O.IOT
          IX2    X1+X3
          SA6    X2 
          EQ     OCSCAN 
          MOVEND
* 
*         PROCESS THIRD, FOURTH, AND FIFTH LETTERS
* 
          MOVSTART  3 
 PNL      GCH    X2                GET THE NEXT CHAR, ADD IT TO B2 AND
          SB2    B2+X2             JUMP TO B2 
          CWD 
          JP     B2 
          MOVEND
          TITLE              EXECUTABLE CODE PROCESSORS 
************************************************************************
*                                                                      *
*         THE FOLLOWING ROUTINES WHOSE LABELS ARE PREFACED BY L3 PRO-  *
*         CESS THE ADDRESS FIELDS OF THE EXECUTABLE INSTRUCTIONS. THEY *
*         ARE REQUIRED TO SET THE I,J AND K FIELDS IN ALL CASES AND IN *
*         SOME CASES THEY MUST ALSO DETERMINE THE G AND H FIELDS  OF   *
*         THE OPCODE. ON ENTRY X4 CONTAINS AN INSTRUCTION PROTOTYPE(IP)*
*         THAT WAS SET AT THE END OF OPCODE FIELD PROCESSING. ON EXIT  *
*         X4 WILL CONTAIN A COMPLETE 15 OR 30 BIT INSTRUCTION AND X1   *
*         WILL CONTAIN A RELOCATION BASE CODE IF NECESSARY.            *
*                                                                      *
*         THE SUBROUTINE -REF- IS CALLED IF A SYMBOL IS ENCOUNTERED.   *
*                                                                      *
*        IN ADDITION, REGISTERS X0,X5,B4,B5,B6,B7, AND A5 ARE RESERVED *
*         FOR USE IN CHARACTER PICK UP AND MUST BE RESTORED IF THEY    *
*         ARE USED OTHERWISE.                                          *
*                                                                      *
*         FOR THE EXECUTABLE INSTRUCTIONS THE OPCODE FIELD ALWAYS BE-  *
*         GINS IN COLUMN 3 AND THERE IS ONLY ONE SPACE BETWEEN OPCODE  *
*         AND ADDRESS.                                                 *
*                                                                      *
************************************************************************
          SPACE  4
************************************************************************
*                                                                      *
*     RJ LABEL -- X4=0100B                                             *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  7 
 L3.RJ    GCH    X1                GET NEXT CHARACTER 
          SX1    X1-1RT 
          ZR     X1,L3.RJT         IF RJT INSTRUCTION 
  
          GCH    X1                GET 1ST CHARACTER OF SYMBOLIC NAME 
          SPACE  2
 L3.UCJP  SB2    B6                BIT COUNT OF CHARACTERS IN X1=6
          SB3    X1                FIRST CHARACTER TO B3
          RJ     REF
          LX4    18                ADJUST THE PROTOTYPE TO A 30 BIT IN- 
          SX7    B5                STRUCTION. 
          SB6    L4.CKRB
          SB1    30 
          SA7    NFLAG             TURN NFLAG ON
          BX4    X3+X4             SET THE ADDRESS AND OUTPUT THE INSTRU
          EQ     WRTEXT 
          MOVEND
 RJT      SPACE  3,14 
************************************************************************
*                                                                      *
*     RJT LABEL,LINENR   OR   RJT LABEL,LINENR,FP                      *
*                                                                      *
************************************************************************
  
  
 LINLIM   =      4096-1 
 RJTFLAG  BSSZ   1           CALLED FROM RJT  FLAG
 RJTGTCP  BSSZ   1           TEMPORARY STORAGE FOR CODE PROTOTYPE 
          SB0    0
          SB0    0
 RJTSR    BSS    2           SAVE REGISTERS ACROSS CALLS TO WRTEXT
  
 L3.RJT   SB4    B4-B6       POSITION AT START OF SYMBOLIC NAME 
          GCH    X1          GET 1ST CHARACTER OF SYMBOLIC NAME 
          SB2    B6          BIT COUNT
          SB3    X1          1ST CHARACTER
          RJ     REF         GET ADDRESS OF SYMBOLIC NAME 
  
          MX6    L.NAME 
          LX4    18 
          SX7    B5 
          BX6    X6*X1       CLEAR LOWER 18 BITS
          SA7    FFLAG       SET TO *FORCE UPPER* 
          SA6    RJTSR+1     SAVE NAME
          SX7    L3.RJTB     RETURN ADDRESS FROM L4.CKRB
          BX6    X3+X4       FORMAT INSTRUCTION 
          SA7    RJTFLAG
          SA6    A6-B5       SAVE FORMATED INSTRUCTION
          GCH    X3 
          CWD 
          RJ     CONVERT     GET BINARY LINE NUMBER IN X1 
  
          BX6    X1 
          SA4    RJTSR       GET SAVED INSTRUCTION
          SA6    A4          SAVE LINE NUMBER 
          GCH    X7          GET DELIMETER IN X7
          SA1    RJTSR+1     GET SAVED NAME 
          BX7    X1+X7
          CWD 
          SA7    A1          SAVE NAME AND TERMINATING CHARACTER
          SB6    L4.CKRB     RETURN ADDRESS 
          SB1    30          BIT COUNT
          EQ     WRTEXT      ISSUE RJ  NAME  CODE 
  
 L3.RJTB  SA1    RJTSR+1     GET TERMINATING CHARACTER AND NAME 
          SB1    X1-1R, 
          NZ     B1,L3.RJTE  IF NOT A FORMAL PARAMETER
          MX4    7*6
          SX7    B5 
          AX1    12 
          EQ     PSUB0       OUTPUT A *SUB* 
  
 L3.RJTE  SX7    0
          SA1    RJTSR       LINE NUMBER
          SA7    RJTFLAG     RESET RETURN ADDRESS 
          SX3    X1-LINLIM
          SA7    FFLAG
          SA4    =XTRACE. 
          SA7    NFLAG
          MI     X3,L3.RJTLT IF LINE NUMBER .LT. 4095 
  
          SA3    RJTGTCP+1
          BX6    X3+X1       INSERT LINE NR. INTO CODE PROTOTYPE
          SA6    A3-B5       SAVE IN TEMPORARY STORAGE
          SX1    7777B       LINE NUMBER .GT. 4095 - 1  INDICATOR 
  
 L3.RJTLT LX1    18 
          BX4    X4+X1       FORMAT INSTRUCTION 
          SB1    30          BIT COUNT
          SB6    L3.RJTA     RETURN ADDRESS 
          EQ     WRTEXT 
  
 L3.RJTA  MX7    0
          RL=    L           ADJUST RELOCATION
          SA4    RJTGTCP
          SA7    RBTEMP      CLEAR RBTEMP 
          ZR     X4,INITL    EXIT IF SECOND WORD NOT NECESSARY
  
          MX6    0
          SA6    A4          CLEAR CODE PROTOTYPE TEMPORARY STORAGE 
          WR1WD  ,INITL      ISSUE VFD WITH ACTUAL LINE NUMBER
  
 L3.ED    SX4    0400B
          SB4    B4-B6
          GCH    X1          GET 1ST CHARACTER OF SYMBOLIC NAME 
          SB2    B6          BIT COUNT
          SB3    X1          1ST CHARACTER
          RJ     REF         GET ADDRESS OF SYMBOLIC NAME 
  
          MX6    L.NAME 
          LX4    18 
          SX7    B5 
          BX6    X6*X1       CLEAR LOWER 18 BITS
          SA7    FFLAG       SET TO *FORCE UPPER* 
          SA6    RJTSR+1     SAVE NAME
          SX7    L3.EDB 
          BX6    X3+X4       FORMAT INSTRUCTION 
          SA7    RJTFLAG
          SA6    A6-B5       SAVE FORMATED INSTRUCTION
          GCH    X3 
          CWD 
          RJ     CONVERT     GET BINARY LINE NUMBER IN X1 
  
          CWD 
          BX6    X1 
          SA4    RJTSR       GET SAVED INSTRUCTION
          SA6    A4          SAVE LINE NUMBER 
          GCH    X7          GET DELIMETER IN X7
          SA1    RJTSR+1     GET SAVED NAME 
          BX7    X1+X7
          CWD 
          SA7    A1          SAVE NAME AND TERMINATING CHARACTER
          SB6    L4.CKRB     RETURN ADDRESS 
          SB1    30          BIT COUNT
          EQ     WRTEXT      ISSUE RJ  NAME  CODE 
  
 L3.EDB   MX7    0
          SA4    RJTSR+1
          SA7    A1 
          SA7    FFLAG
          SA7    NFLAG
          SA1    RJTSR
          SA4    =XLABEL. 
          SB1    30 
          SB6    L3.EDC 
          IX4    X4+X1
          EQ     WRTEXT 
  
 L3.EDC   MX7    0
          RL=    L
          SA7    RBTEMP 
          EQ     INITL
          SPACE  4
************************************************************************
*     JP B1       --X4=0210B                                           *
*     JP B1+LABEL -- .  .                                              *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  6 
 L3.JP    BX1    X5 
          AX1    18 
          BX2    -X0*X1      ISOLATE NUMBER OF B REGISTER 
          SX3    X2-1R0 
          LX3    3
          BX4    X4+X3       PLUG NUMBER INTO INSTRUCTION 
          AX1    X5,B6
          SB4    B0 
          BX1    -X0*X1            FIRST CHARACTER OF LABEL TO X1 
          NZ     X1,L3.UCJP        IF THERE IS A LABEL THEN PROCESS IT E
          SB6    INITL             EXIT.
          SX7    B5 
          SB1    30 
          LX4    18 
          SA7    NFLAG             TURN NFLAG ON
          EQ     WRTEXT 
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     ZR XJ,SYMBOL  -- X4=0300B                                        *
*     NZ  .   .     -- X4=0310B                                        *
*     PL  .   .     -- X4=0320B                                        *
*     NG  .   .     -- X4=0330B                                        *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  7 
 L3.XJP   SB4    B4-12             SKIP TO J AND SET IT 
          AX2    X5,B4
          SB4    B0 
          AX1    X5,B6
          BX2    -X0*X2 
          SB2    B6 
          BX1    -X0*X1 
          SX2    X2-1R0 
          SB3    X1 
          BX4    X4+X2
          RJ     REF               GET THE RELATIVE ADDRESS, SET IT AND 
          LX4    18                OUTPUT THE INSTRUCTION 
          SB6    L4.CKRB
          SB1    30 
          BX4    X3+X4
          EQ     WRTEXT 
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     EQ LABEL       -- X4=0400B                                       *
*     EQ BI,BJ,LABEL --  .   .                                         *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  9 
 L3.EQ    GCH    X1 
          SX7    X1-1RB 
          NZ     X7,L3.UCJP        IF THERE ARE NO B REGISTERS SPECIFIED
          AX3    X5,B4             THEN PROCESS AN UNCONDITIONAL JUMP.
          BX2    -X0*X5            X2.= J 
          SA5    A5+B5
          BX3    -X0*X3            X3.= I 
          SB4    B7-B6
          IX6    X2-X3
          GCH    X1 
          ZR     X6,L3.UCJP        IF I=J THEN PROCESS AN UNCONDITIONAL 
          LX3    3                 JUMP ELSE SET I,J AND K AND EXIT.
          SX4    X4-363B
          SB2    B6 
          IX3    X2+X3
          SB3    X1 
          IX4    X4+X3
          RJ     REF
          LX4    18 
          SB1    30 
          BX4    X3+X4
          SB6    L4.CKRB
          EQ     WRTEXT 
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     NE BI,BJ,LABEL  -- X4=0500B                                      *
*     GE  .  .   .    -- X4=0600B                                      *
*     LT  .  .   .    -- X4=0700B                                      *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  7 
 L3.BJP   SB4    B4-12
          SB2    B6 
          AX2    X5,B4
          BX3    -X0*X5            X3.= J 
          SA5    A5+B5
          SX4    X4-363B
          BX2    -X0*X2            X2.= I 
          SB4    B7-B6             CONVERT I AND J TO BINARY AND ADD THE
          LX2    3                 THE OPCODE PROTOTYPE.
          IX4    X4+X3
          AX1    X5,B4             FIRST CHARACTER OF THE LABEL TO X1 
          IX4    X4+X2
          BX1    -X0*X1 
          LX4    18                MAKE A 30 BIT INSTRUCTION
          SB3    X1 
          SB4    B4-B6
          RJ     REF
          SB1    30 
          SB6    L4.CKRB
          BX4    X4+X3             SET THE ADDRESS AND EXIT TO OUTPUT TH
          EQ     WRTEXT            INSTRUCTION. 
          MOVEND
          SPACE  3
*** 
*         CXI  XJ 
* 
 L3.CNT   AX6    B4,X5
          SB4    B4-18
          BX4    -X0*X6            I
          IX6    X4-X7
          AX5    B4,X5
          BX3    -X0*X5            J
          IX3    X3-X7
          SX4    X6+470B
          LX4    3
          IX4    X3+X4
          LX4    3
          IX4    X3+X4             47IJJ
          EQ     L4.15
          SPACE  4
************************************************************************
*                                                                      *
*     BXI XJ                                                           *
*      .  XJ+XK                                                        *
*      .  XJ-XK                                                        *
*      .  XJ*XK                                                        *
*      .  -XJ                                                          *
*      .  -XJ+XK                                                       *
*      .  -XJ-XK                                                       *
*      .  -XJ*XK                                                       *
*                                                                      *
*         ON ENTRY  X4=0                                               *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  14
 L3.BOOL  AX4    X5,B4             PICK I 
          SB4    B4-12             SKIP THE SPACE 
          BX4    -X0*X4 
          AX1    X5,B4             PICK 1ST CH OF THE ADD. FIELD
          SB1    -1R0              CONSTANT FOR NUMERIC CONVERSION
          SX4    X4+B1             SET I
          SX2    140B              MASK FOR BITS 2,3 OF THE OPCODE
          BX1    X2*X1
          IX4    X1+X4             SET BITS 2,3 
          LX1    54 
          PL     X1,L3.BNM1        IF THE FIRST CH WAS A MINUS THEN SKIP
          SB4    B4-B6             THE X. 
 L3.BNM1  SB4    B4-B6
          LX4    3                 POSITION OPCODE FOR J
          GCH    X1                PICK J 
          SX1    X1+B1             CONVERT TO OCTAL 
          AX2    X5,B4             PICK THE 2ED OPERATOR
          IX4    X4+X1             SET J
          BX2    -X0*X2 
          SX1    300B              MASK FOR BITS 0,1 OF THE OPCODE
          LX3    X1,B5             DATA FOR BITS 0,1 OF THE OPCODE
          SB3    X2-45B            B3.=OPERATOR-45B 
          AX3    X3,B3             SHIFT DATA AND MASK TO SELECT BITS 0,
          BX3    X3*X1
          IX4    X3+X4
          LX4    3                 POSITION OPCODE FOR K
          ZR     X3,L3.BNK         IF THE 2ED OPERATOR WAS A SPACE THEN 
          SA5    A5+B5             ELSE PICK AND SET K. 
          NZ     B4,L3.BNM2        IF THERE WAS A PRECEEDING MINUS THEN 
          SB7    B7-B6             K IS THE 2ED CH IN THE NEW WORD. 
 L3.BNM2  AX1    X5,B7
          BX1    -X0*X1 
          SX1    X1+B1
          NZ     B4,L3.BNM3        IF THERE WAS A PRECEEDING MINUS THEN 
          BX2    -X0*X4            EXCHANGE J AND K.
          LX1    3
          BX4    X0*X4
          AX2    3
          BX4    X2+X4
 L3.BNM3  IX4    X1+X4
          EQ     L4.15
          MOVEND
          SPACE  2
          MOVSTART  2 
 L3.BNK   MX0    57 
          SB1    3
          AX2    X4,B1
          BX2    -X0*X2 
          IX4    X4+X2
          EQ     L4.15
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     MXI CON.   -- X4=43000B                                          *
*     AXI  .     -- X4=21000B                                          *
*     LXI  .     -- X4=20000B                                          *
*     AXI BJ,XK  -- X4=21000B                                          *
*     LXI  .  .  -- X4=20000B                                          *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  6B
 L3.MX    BSS    0
 L3.SH    AX1    X5,B4             PICK I 
          SB4    B4-12             SKIP THE SPACE 
          BX1    -X0*X1 
          SB3    -1R0              CONSTANT FOR NUMERIC CONVERSION
          SX1    X1+B3
          LX1    6
          BX4    X4+X1             SET I
          AX1    X5,B4             PICK THE 1ST CH OF ADD FIELD 
          BX1    -X0*X1 
          SX1    X1+B3
          SB4    B4-B6
          NG     X1,L3.SNOM        IF THE 1ST CH IS ALPHABETIC THEN 
          AX2    X5,B4             NOMINAL SHIFT. 
          BX2    -X0*X2            PICK 2ED CH OF THE ADD. FIELD
          SX3    X2+B3
          NG     X3,L3.SC2         IF ALPHA THEN GOTO L3.SC2 ELSE GOTO
          EQ     L3.SC1            L3.SC1.
          MOVEND
          MOVSTART  4B
 L3.SNOM  SX4    X4+2000B          IP.=IP+2000B FOR NOMINAL SHIFTS
          AX1    X5,B4             PICK J 
          BX1    -X0*X1 
          SX1    X1+B3
          SA5    A5+B5             GET NEXT WORD
          AX2    X5,B7             PICK K AS THE 1ST CH OF THE NEW WORD 
          BX2    -X0*X2 
 L3.SC1   SX2    X2-1R0 
          LX1    3
          BX4    X4+X2             SET K
 L3.SC2   IX4    X4+X1             SET J
          EQ     L4.15
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     NXI BJ,XK  -- X4=24000B                                          *
*     UXI  .  .  -- X4=26000B                                          *
*     PXI  .  .  -- X4=27000B                                          *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  5B
 L3.PUN   AX1    X5,B4
          BX1    -X0*X1 
          SB4    B4-18
          LX1    6
          IX4    X4+X1             OPCODE.=OPCODE+I*8**2
          AX2    X5,B4
          BX2    -X0*X2 
          SA5    A5+B5
          LX2    3
          IX4    X4+X2             OPCODE.=OPCODE+J*8 
          AX3    X5,B7
          BX3    -X0*X3 
          IX4    X4+X3
          SX4    X4-3663B          CONVERT I,J,K TO BINARY
          EQ     L4.15
          MOVEND
          EJECT 
************************************************************************
*                                                                      *
*     FXI XJ+XK  -- X4=0                                               *
*      .  . - .  --  .                                                 *
*      .  . * .  --  .                                                 *
*      .  . / .  --  .                                                 *
*                                                                      *
*     DXI . + .  -- X4=02000B                                          *
*      .  . - .  --  .                                                 *
*      .  . * .  --  .                                                 *
*                                                                      *
*     IX1 . + .  -- X4=06000B                                          *
*      .  . - .      .                                                 *
*                                                                      *
************************************************************************
          SPACE  2
 XRGMSK   VFD    24/1RX,18/1RX,18/1RX 
  
 L3.ARIT  BSS    0
 .T       IFNE   TEST,0 
          SA1    XRGMSK 
          BX2    X1*X5
          BX1    X1-X2
          NZ     X1,ILL      IF NOT XI XJ OP XK 
 .T       ENDIF 
          AX1    B6,X5
          BX1    -X0*X1 
          SA1    X1+ARITAB-1R+     PICK UP OPCODE MASK
          BX4    X4+X1             OPCODE.=IP .OR. MASK 
          EQ     L3.PUN            GO TO PUN TO SET I,J,K 
          SPACE  2
          MOVSTART  4B
 ARITAB   DATA   30000B            TABLE OF OPCODE MASKS FOR THE ARITHME
          DATA   31000B            OPERATIONS.
          DATA   40000B 
          DATA   44000B 
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*     RXI XJ+XK  -- X4=0                                               *
*      .  . - .  --                                                    *
*      .  . * .  --                                                    *
*      .  . / .  --                                                    *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  2 
 L3.RX    AX1    B6,X5
          BX1    -X0*X1 
          ZR     X1,L3.DRL   SENSE READ LCM 
          SA4    X1+ROUNDTAB-1R+   PICKUP OPCODE MASK 
          EQ     L3.PUN            GO TO PUN TO SET I, J, K 
          MOVEND
          MOVSTART 4
 ROUNDTAB DATA   34000B            TABLE OF OPCODE MASKS FOR ROUNDED
          DATA   35000B            ARITHMETIC 
          DATA   41000B 
          DATA   45000B 
          MOVEND
***** 
*     RXJ  XK    X4=01400B
*     WXJ  XK    X4=01500B
* 
          MOVSTART 5
 L3.DRL   SX4    01400B 
 L3.RWX   AX1    B4,X5
          SB4    B4-18
          BX1    -X0*X1      EXTRACT J
          AX2    B4,X5
          LX1    3           POS. J 
          BX2    -X0*X2      EXTRACT K
          IX4    X1+X4       OR IN J
          IX4    X2+X4       OR IN K
          SX4    X4-363B     CONVERT J,K TO BINARY
          EQ     L4.15
          MOVEND
          SPACE  4
************************************************************************
*                                                                      *
*         THIS ROUTINE PROCESSES THE ADDRESS FIELD OF THE SET INSTRUC- *
*         TIONS. IT IS REQUIRED TO SET THE LEAST SIGNIFICANT DIGIT OF  *
*         THE OPCODE(H FIELD) AND THE I,J AND K FIELDS. ON ENTRY X4    *
*         WILL CONTAIN EITHER 51000B,61000B OR 71000B. THE POSSIBLE    *
*         ADDRESS FIELDS THAT MAY BE ENCOUNTERED ARE                   *
*                                                                      *
*                   RJ,                                                *
*                   RJ+OR-RK,                                          *
*                   RJ+OR-AE,OR                                        *
*                   AE                                                 *
*              WHERE AE(ADDRESS EXPRESSION) IS EITHER                  *
*                   OCTAL CONSTANT,                                    *
*                   SYMBOL(+OR-OCTAL CONSTANT)(+OR-OCTAL CONSTANT),OR  *
*                   SYMBOL-SYMBOL(+OR-OCTAL CONSTANT).                 *
*                                                                      *
*         ON EXIT X4 CONTAINS  EITHER A 15 OR 30 BIT INSTRUCTION.      *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  3 
 L3.S1TB  DATA   1,-1,0 
          MOVEND
          SPACE  2
          MOVSTART  3 
 L3.S3TB  DATA   3000B,5000B,2000B
          MOVEND
          SPACE  2
          MOVSTART  3 
 L3.S6TB  DATA   4000B,5000B,1000B
          MOVEND
          SPACE  2
          MOVSTART  4 
 L3.SET   AX1    X5,B4             PICK AND SET THE I FIELD 
          BX1    -X0*X1 
          SX1    X1-1R0 
          SB4    B4-12             SKIP THE SPACE 
          LX1    6
          BX4    X4-X1
          GCH    X1                FIRST CH OF THE ADDRESS FIELD TO X1
          SB3    X1 
          BX7    X7-X7             NEGFLAG OFF, ADD.SUM.= 0 
          SB2    B6                B2.= BIT COUNT OF CHARACTERS IN X1 (B
          JP     B3+L3.JVEC        JUMP INTO JVEC WITH FIRST CHARACTER
          MOVEND
          SPACE  2
          MOVSTART  7 
 L3.S1    MX3    58 
          AX6    X5,B4
          SA2    =77600000000B
          BX3    -X3*X1            X3.= LOW ORDER 2BITS OF FIRST CHARACT
          BX6    -X0*X6 
          SA3    X3+L3.S1TB 
          SB1    X6                B1.= SECOND CHARACTER
          LX2    X2,B1
          SA0    X3                A0.=S1TB(X3) 
          PL     X2,L3.S7          IF 2ED CHARACTER IS NOT AN OCTAL DIGI
          LX1    6
          SB4    B4-B6
          BX1    X1+X6             X1.= FIRST AND SECOND CHARACTERS 
          SB2    B2+B6
          AX3    X5,B4             THEN PROCESS AN A.E. 
          BX3    -X0*X3 
          SA2    X3+L3.JVEC 
          SB1    X2 
          SX6    X6-1R0            PICK UP ORDINAL FROM JVEC WITH 3RD CH
          JP     B1+L3.S3JT        INTO S3JT WITH IT. 
          MOVEND
          SPACE  2
 L3.S3JT  SA1    A0+L3.S3TB+1      SPACE OR ZERO BYTE -- H.= 3,4,OR 6 
          EQ     L3.S3EX           J.=(X6), K.=0
          EQ     L3.S7
 +        BX7    -X7+X7            MINUS -- NEGFLAG ON
 +        LX6    3                 PLUS  -- H.=H+(A0), CONTINUE ANALYSIS
          SX3    A0 
          BX4    X4+X6             J.=(X6)
          LX3    9
          SB4    B7 
          BX1    -X0*X5            X1.= 4TH CHARACTER 
          IX4    X4+X3
          SB3    X1 
          SA5    A5+B5
          SB1    X1-1RB 
          SB2    B6                BC.= 6 
          NZ     B1,L3.S7          IF 4TH CHARACTER IS NOT B THEN PROCES
          AX6    X5,B4             AN A.E.
          SA3    =77600000000B
          BX6    -X0*X6            X6.= 5TH CHARACTER 
          SB1    X6 
          LX3    X3,B1
          PL     X3,L3.S7          IF 5TH CHARACTER IS NOT AN OCTAL DIGI
          LX1    6
          SB4    B4-B6
          BX1    X1+X6
          SB2    B2+B6
          AX2    X5,B4             THEN GO PROCESS AN A.E.
          SB2    B2+B6             BC.= BC+6
          LX1    6
          BX2    -X0*X2            X2.= 6TH CHARACTER 
          SB4    B4-B6
          BX1    X1+X2             X1.= 4TH,5TH,AND 6TH CHARACTERS
          SX2    X2-1R
          NZ     X2,L3.S7          IF 6TH CHARACTER IS NOT A ZERO BYTE T
          SA1    A0+L3.S6TB+1      PROCESS AN A.E.
          SX6    X6-1R0 
          IX4    X4+X1             H.= H+1,4,5
          BX4    X4+X6             K.= (X6) 
          PL     X7,L4.15          IF NEGFLAG IS ON THEN H.=H+1 
          SX4    X4+1000B 
          EQ     L4.15
          SPACE  2
          MOVSTART  5 
 L3.S11M  BX7    -X7
          GCH    X1 
          SB3    X1 
          SPACE  2
 L3.S11Z  BSS    0
 L3.S11P  BSS    0
 L3.S7.1A BSS    0
 L3.S7    BX6    X7 
          LX4    15 
          RJ     EVAL 
          SB6    L4.CKRB
          SB1    30 
          EQ     WRTEXT 
          MOVEND
          SPACE  2
          MOVSTART  2 
 L3.S3EX  LX6    3
          IX4    X4+X1
          NO
          BX4    X4+X6
          EQ     L4.15
          MOVEND
          SPACE  2
************************************************************************
*                                                                      *
*         JUMP VECTOR AND CH CODE CONVERSION CONSTANTS USED FOR        *
*         DECISIONS ON CHS IN THE ADDRESS FIELD OF THE SET INSTRUCTIONS*
*                                                                      *
*         BITS 59-30 ARE A TRUE JUMP VECTOR WHILE THE OTHER THREE      *
*         FIELDS IN EACH WORD ARE USED AS ORDINALS TO SMALLER JUMP     *
*         VECTORS. THE WORD IS PICKED UP USING THE CH CODE AS AN INDEX *
*         AND THE PROPER FIELD IS SEPARATED TO AN INDEX REGISTER.      *
*                                                                      *
*         BITS 59-30 ARE USED TO SEPARATE A,B,X,OTHER ALPHABETIC CHS   *
*                    INCLUDING .)#[]89 , OCTAL DIGITS                  *
*         BITS 24-29 SEPARATE  SPACE OR ZERO BYTE,+ AND -              *
*                                                                      *
*         BITS 23-18 SEPARATE  OCTAL DIGITS, ALPHABETIC, AND B         *
*                                                                      *
*         BITS 17-0  SEPARATE  SPACE OR ZERO BYTE, ALPHABETIC, -, +    *
*                                                                      *
************************************************************************
          SPACE  2
 L3.JVEC  EQ     ILL               00                     L3.JVEC  EQ 
 -        VFD    6/0,6/1,18/0 
          EQ     L3.S1
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S1
 -        VFD    6/0,6/2,18/1 
          EQ     L3.S7.1A          C                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          D                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          E                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          F                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          G                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          H                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          I                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          J                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          K                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          L                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          M                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          N                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          O                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          P                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          Q                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          R                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          S                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          T                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          U                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          V                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          W                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S1
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          Y                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          Z                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S11Z           0                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           1                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           2                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           3                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           4                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           5                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           6                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S11P           7                               EQ 
 -        VFD    6/0,6/0,18/1 
          EQ     L3.S7.1A          8                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          9                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               +                               EQ 
 -        VFD    6/1,6/1,18/3 
          EQ     L3.S11M           -                               EQ 
 -        VFD    6/2,6/1,18/2 
          EQ     ILL               *                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               /                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               (                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          )                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          $                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               =                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               BLANK                           EQ 
 -        VFD    6/0,6/1,18/0 
          EQ     ILL               ,                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          .                               EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          EQUIV                           EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          RIGHT BRACKET                   EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     L3.S7.1A          LEFT BRACKET                    EQ 
 -        VFD    6/0,6/1,18/1 
 JTEND    EQU    DEBUG
          IFEQ   JTEND,1
          EQ     ILL               COLON                           EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               NOT EQUAL                       EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               RIGHT ARROW                     EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               OR                              EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               AND                             EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               UP ARROW                        EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               DOWN ARROW                      EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               LESS THAN                       EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               GREATER THAN                    EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               LESS THAN OR EQUAL              EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               GREATER THAN OR EQUAL           EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               NOT                             EQ 
 -        VFD    6/0,6/1,18/1 
          EQ     ILL               SEMI-COLON                      EQ 
 -        VFD    6/0,6/1,18/1 
          ENDIF 
          TITLE              PSEUDO-OP PROCESSORS 
************************************************************************
*                                                                      *
* VFD-    THIS ROUTINE PROCESSES THE VFD PSEUDO-OP. THE ACCEPTABLE     *
*         DATA FIELDS ARE-                                             *
*                                                                      *
*                   (N)/(OCTAL CONSTANT),N@60,                         *
*                   (N)/(ADDRESS EXPRESSION) IF THIS RESULTS IN A RE-  *
*                   LOCATABLE QUANTITY THEN IT MUST BE IN THE LOWER 
*                   18 BITS OF THE WORD,                               *
*                   (N*6)/(M)(C,H,L OR R)(CHARACTER STRING),0<N@10,    *
*                   0@M@10                                             *
*         ALSO THE SUM OF THE BITS SPECIFIED IN ANY ONE APPEARANCE OF  *
*         A VFD MUST BE 15,30 OR 60.                                   *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  1 
 BCTMP    BSS    1
          MOVEND
          SPACE  2
          MOVSTART  11
 SPACES   DATA   0                 TABLE OF BLANKS USED FOR FILLING CHAR
          DATA   1R                STRING DATA. 
          DATA   2R 
          DATA   3R 
          DATA   4R 
          DATA   5R 
          DATA   6R 
          DATA   7R 
          DATA   8R 
          DATA   9R 
          DATA   10R
          MOVEND
          SPACE  2
 L3.VFD   SB3    B6+B7
          BX4    X4-X4
          SB4    B4-12             SKIP 2 CHARACTERS
          PL     B4,L3.V1 
          SA5    A5+B5
          SB4    B4+B3
          SPACE  2
 L3.V1    GCH    X1                SCAN TO ADDRESS FIELD
          SB3    X1 
          CWD 
          EQ     B1,B3,L3.V1
          SA0    B0                BIT COUNT.=0 
          SPACE  2
 L3.V2    SA2    =77740000000B
          SB1    -1R0              B1.=-33B 
 L3.V3    SX7    X1+B1             CONVERT THE FIELD LENGTH TO BINARY 
          LX6    X3,B5
          GCH    X1 
          LX3    3
          SB3    X1 
          IX3    X3+X6
          CWD 
          LX6    X2,B3
          IX3    X3+X7
          NG     X6,L3.V3 
          SB2    X3 
          GCH    X1 
          CWD 
          LX4    X4,B2
          SX7    A0+B2
          SA0    B2 
          SB3    X1 
          LX6    X2,B3
          SB2    B6 
          SA7    BCTMP             EXAMINE THE FIRST CHAR OF THE DATA FI
          PL     X6,L3.V12         IF NOT NUMERIC THEN TREAT AN ADDRESS 
          GCH    X6                PRESSION ELSE DECIDE BETWEEN OCTAL CO
          SB3    X6                STANT AND CHARACTER. 
          SA3    =77600000000B
          CWD 
          LX2    X3,B3
          SX1    X1+B1
          PL     X2,L3.V5 
          GCH    X7 
          SB3    X7 
          CWD 
          LX2    X3,B3
          SX6    X6+B1
          LX1    3
          PL     X2,L3.V6 
          LX2    X3,B0
          BX3    X1+X6
          SPACE  2
 L3.V7    SX1    X7+B1             OCTAL CONSTANT 
          GCH    X7 
          CWD 
          LX3    3
          SB2    X7 
          BX3    X3+X1
          LX6    X2,B2
          NG     X6,L3.V7 
          SPACE  2
 L3.V8    GCH    X7                B3.= NEXT CHARACTER, EXIT
          SB3    X7 
          CWD 
          EQ     L3.V50 
          SPACE  2
          MOVSTART  2 
 L3.V5    SB1    X6-1RB 
          BX3    X1 
          SB2    X3 
          NZ     B1,L3.V9          IF CH=B THEN 1 DIGIT OCTAL CONSTANT E
          EQ     L3.V8             ASSUME CHARACTER DATA. 
          MOVEND
          SPACE  2
          MOVSTART  2 
 L3.V6    SB1    X7-1RB 
          NZ     B1,L3.V20         IF CH=B THEN 2 DIGIT OCTAL CONSTANT E
          BX3    X1+X6             CHARACTER DATA.
          EQ     L3.V8
          MOVEND
          SPACE  2
          MOVSTART  3 
 L3.V30   SB1    B2-B1
          SX7    B1+B1
          SA1    B1+SPACES
          SB1    X7 
          LX7    1
          SB1    B1+X7
          LX3    X3,B1
          BX3    X1+X3
          EQ     L3.V40 
          MOVEND
          SPACE  2
          MOVSTART  2 
 L3.V12   MX7    0
          BX6    X6-X6
          RJ     EVAL 
          SB3    B1 
          BX3    X3-X3
          EQ     L3.V50 
          MOVEND
          SPACE  2
          MOVSTART  5 
 L3.V21   SA2    =40000000000000060000B 
          SB2    B0 
 L3.V22   GCH    X1 
          SB3    X1 
          CWD 
          LX7    X2,B3
          NG     X7,L3.V40
          LX3    6
          BX3    X3+X1
          SB2    B2+B5
          EQ     L3.V22 
          MOVEND
          SPACE  2
          MOVSTART  7 
 L3.V20   SB2    10 
          BX6    X7 
 L3.V9    ZR     X3,L3.V21         IF CH COUNT=0 THEN PACK UNTIL COMMA,S
          SB1    B0                ZERO BYTE ELSE KEEP COUNT. 
          BX3    X3-X3
 L3.V29   GCH    X1 
          SB3    X1 
          CWD 
          EQ     B1,B2,L3.V40 
          ZR     X1,L3.V30
          LX3    6
          SB1    B1+B5
          BX3    X3+X1
          EQ     L3.V29 
          MOVEND
          SPACE  2
 L3.V40   SB1    X6-1RR 
          ZR     B1,L3.V50
          SB2    B2+B2
          SB1    B2+B2
          SX1    X6-1RH 
          SB1    B1+B2
          SB1    A0-B1
          LX3    X3,B1
          NZ     X1,L3.V50
          SA0    -B5
 L3.V41   SB1    B1-B6
          SA0    A0+B5
          PL     B1,L3.V41
          SA1    A0+SPACES
          BX3    X1+X3
 L3.V50   SB1    B3-1R, 
          SA1    BCTMP
          BX4    X3+X4
          SA0    X1 
          BX3    X3-X3
          GCH    X1 
          CWD 
          ZR     B1,L3.V2 
          SB6    L4.CKL 
          SB1    A0 
          EQ     WRTEXT 
* 
*         DIS 
* 
          MOVSTART  2 
 DISLOC   BSS    2                 WORD COUNT AND LOCATION FOR PDIS 
          MOVEND
  
 PDIS     SX7    A5+B5             SAVE ADDRESS OF INPUT
          SB1    60                SET BIT COUNT FOR WRTEXT 
          AX5    6                 SHIFT OFF COMMA
          MX0    60-6 
          BX6    -X0*X5            MASK OFF WORD COUNT
          SB6    PDIS1             SET RETURN ADDRESS FOR WRTEXT
          SX6    X6-1R0            CONVERT DISPLAY TO BINARY
          SA6    DISLOC 
          SA4    A5+B5
          SA7    A6+B5
          EQ     WRTEXT            GO ADD TO TEXT TABLE 
  
 PDIS1    SA5    DISLOC 
          SX0    B5 
          IX7    X5-X0             DECREMENT WORD COUNT 
          ZR     X7,INITL 
          SA4    A5+B5             ADDR OF LAST WORD
          SA7    A5 
          IX6    X4+X0
          SA6    A4                SAVE ADDR OF NEXT WORD 
  
          WR1WD  X6,PDIS1          WRITE A WORD AND LOOP FOR NEXT 
* 
*         DATA
* 
          MOVSTART  7 
 PDATA    SB4    B4-18
          PL     B4,PDAT1 
          SA5    A5+B5
          SB4    B4+60
 PDAT1    GCH    X3 
          SB2    X3 
          CWD 
          EQ     B1,B2,PDAT1
          RJ     CONVERT
          SB1    B6+B7
          SB6    L4.CKL 
          BX4    X1 
          EQ     WRTEXT 
          MOVEND
          SPACE  4
*** 
*         PAPL - PROCESS APL MACRO CALL 
 PAPL     SB4    B7 
          BX4    -X0*X5 
          ZR     X4,PAPL1    IF NO ARG
          SA5    A5+B5
          GCH    X1 
          SX2    X1-1R- 
          NZ     X2,PAPL2 
          MX4    60          WORD = -0
 PAPL1    WR1WD  ,INITL 
  
 PAPL2    MX7    0
          BX6    X6-X6
          SB3    X1 
          MX4    0
          SB2    6
          RJ     EVAL        EVALUATE THE EXPRESSION
          WR1WD  ,L4.CKL
  
 PLAP     SPACE  3,14 
**        PLAP - PROCESS *LAP* MACRO. 
* 
  
 PLAP     SB4    B4-12
  
 PLAP1    GCH    X3 
          CWD 
          SX6    X3-1R
          ZR     X6,PLAP1    IF BLANK 
          SX6    X3-1R? 
          ZR     X6,PLAP2    IF ?MMM SYMBOL 
          SB3    X3 
          BX1    X3 
          SB2    B6 
          RJ     REF
          LX2    -P.RB
          MX1    -L.RB
          BX6    -X1*X2      BLOCK ORDINAL
          SA6    NNAME
          BX6    X3 
          SA6    VNAME       RA 
          SX3    B1-1R0      LAST CHARACTER 
          EQ     PLAP3
  
 PLAP2    GCH    X3          FIRST DIGIT OF MMM 
          MX6    0
          SA6    VNAME
          RJ     CONVERT
          SX6    X1-1 
          SA6    NNAME       BLOCK ORDINAL
  
 PLAP3    SX1    X3+1R0 
          ZR     X1,PLAP4    IF END OF LINE 
          SX1    X1-1R
          ZR     X1,PLAP4    IF BLANK 
          RJ     NMLG 
          RJ     CONVERT
  
 PLAP4    MX0    1
          SA2    VNAME
          IX3    X1+X2       RA + BIAS
          BX4    X0+X3       ADD LCM BIT
          SA2    NNAME
          SX3    2           COMMON RELOCATION
          LX3    P.RL 
          LX2    P.RB 
          BX6    X2+X3
          SA6    RBTEMP 
          WR1WD 
  
          SA2    NNAME
          RJ     ALR         LCM RELOCATION 
          EQ     INITL
  
*** 
*         ALR - ADD LCM RELOCATION
*         ADDS THE LCM FILL INFORMATION TO THE FILL CHAIN 
* 
*         ENTRY  X2 - RB ORDINAL OF LCM BLOCK - 1 
* 
 ALR      ENTRY. *                 ** ENTRY/EXIT ** 
          PX1    X2 
          SA3    =22.P0 
          DX1    X1*X3             22*RB ORDINAL
          SA3    TEXT.ADD 
          SA5    CORGTAB
          IX1    X1+X5             CORGTAB + 22*RB
          SA2    X3-3              LCT, ORGC OF LOCAL BLOCK 
          SA3    X1+2              LCT,ORGC OF COMMON BLOCK 
          MX0    1
          BX6    X0+X3
          LX2    30 
          BX7    X0+X2
          SA6    A3 
          SA5    FREEMEM           NEXT FREE CELL ADDRESS 
          SA2    MEMEND 
          MX0    60-18
          SA3    X1                CORGTAB HEADER WORD
          SX6    X5+B5             FREEMEM + 1
          BX1    -X0*X3            POINTER TO END OF CHAIN
          IX2    X2-X5             MEMEND - FREEMEM 
          BX3    X0*X3             BLOCK NAME 
          NG     X2,STOVER         IF STORAGE OVERFLOW
  
          SA6    A5                FREEMEM = FREEMEM + 1
          BX7    X7+X1             INSERT POINTER 
          IX6    X5+X3             INSERT LINK TO CHAIN 
          SA7    X5                FILL WORD
          SA6    A3                NEW HEAD OF CHAIN
          BX7    X7-X7
          SA7    RBTEMP 
          EQ     ALR
 HOL      SPACE  3
*** 
*         PHOL - PROCESS HOL MACRO CALL 
* 
 PHOL     MX0    60-6 
          BX1    -X0*X5            TYPE ( H , L OR R )
          AX5    6
          SA4    A5+B5             CHARACTERS 
          SX6    X1-1RH 
          ZR     X6,PHOL1          IF H TYPE DATA 
          BX2    -X0*X5 
          SX3    X2-1R0            CHAR COUNT ( 1 - 9 ) 
          IX2    X3+X3
          LX3    2
          IX7    X2+X3             6*CC 
          SB1    X7-1 
          MX0    1
          AX0    B1,X0             FORM MASK
          BX4    X0*X4             REMOVE TRAILING BLANKS 
          SX1    X1-1RL 
          ZR     X1,PHOL1          IF L FORMAT
          SB1    B1+B5
          LX4    B1,X4
 PHOL1    WR1WD  ,INITL            WRITE WORD AND RETURN
 REPI     SPACE  3
*** 
*         REPI MACRO PROCESSING 
* 
  
 PREPIC   VFD    12/4300B,12/2,36/1  REPI TABLE HEADER WORD 
          BSS    1                 33/INC,27/S. 
          BSS    1                 18/REP COUNT,15/WORDS,27/DESTIN ADD
  
 PREPI    SA1    S.                RB AND RA OF LAST ORG
          SA5    A5+B5             NEXT WORD
          BX6    X1 
          SA6    PREPIC+1 
          SB4    B7 
          GCH    X3 
          RJ     CONVERT           DATA BLOCK LENGTH
          LX1    27 
          BX6    X1 
          SA6    PREPIC+2 
          RJ     NMLG              SKIP 
          RJ     NMLG              COMMA
          RJ     CONVERT
          SA2    PREPIC+2 
          LX1    42 
          BX6    X1+X2             OR IN REP COUNT
          SA6    A2 
          RJ     NMLG              NEXT CHAR
          NZ     X2,PREPI1         IF NO MORE ARGS
          RJ     NMLG 
          RJ     CONVERT           CONVERT INCREMENT
          SA2    PREPIC+1 
          LX1    27 
          BX6    X1+X2
          SA6    A2 
          RJ     NMLG 
          NZ     X2,PREPI1         IF NO COMMA
          RJ     NMLG 
          RJ     CONVERT
          SA2    S. 
          SA3    PREPIC+2 
          IX1    X1+X2
          BX6    X1+X3
          SA6    A3 
  
 PREPI1   RJ     FOTEXT            FORCE OUT SOURCE DATA
          SA1    FV.LGO 
          SB1    1
          ZR     X1,NOBINPO        IF BINARY OUTPUT OPTION OFF (B=0)
          WRITEW F.LGO,PREPIC,3    REPL (43) TABLE
          SB5    B1+
          EQ     NOBINPO
 LDSET    SPACE  4,10 
*** 
*         PLDSET - LIST AND SKIP *LDSET* DIRECTIVE. 
* 
 PLDSET   BSS    0
          SA1    =XOLIST
          SB1    1
          ZR     X1,INITL    IF OBJECT LISTING NOT SELECTED 
          LISTL  LINE,8      LIST *LDSET* DIRECTIVE 
          SB5    B1 
          EQ     INITL
 EQU      SPACE  4
* 
*      EQU-1.SET ALABEL TO ZERO 
*          2.RESTORE NFLAG FROM X4,A4 
* 
          MOVSTART  2 
 L3.EQU   BX6    X4 
          SA7    ALABEL 
          SA6    A4 
          EQ     NOBINPO
          MOVEND
* 
*         BSS 
* 
          MOVSTART  8 
 PBSS     SB4    B4-B6
          CWD 
          GCH    X3                GET FIRST CHARACTER FOR CONVERT
          SX6    B5 
          CWD 
          SA6    FFLAG             FORCE UPPER
          RJ     CONVERT           GO CONVERT ARGUMENT
          BX7    X1 
          SB1    B0                BIT COUNT FOR WRTEXT 
          SB6    PBSS1             RETURN ADDRESS FOR WRTEXT
          SA7    BSPFLAG           SAVE ARGUMENT
          BX4    X4-X4
          EQ     WRTEXT            GO FORCE UPPER 
          MOVEND
          SPACE  2
          MOVSTART  4 
 PBSS1    SA1    BSPFLAG
          ZR     X1,PBSS3          SENSE BSS 0
          SA3    TEXT.ADD 
          SA2    X3-3 
          IX6    X2+X1             ADD ARGUMENT TO ORGC 
          SA6    A2 
          RJ     FOTEXT            GO FORCE OUT TEXT TABLE
 PBSS3    SB3    60 
          EQ     NOBINPO
          MOVEND
* 
*         USE AND USELCM
* 
  
 PUSEA    BSSZ   1
  
 PUSE     SB4    B4-B6
          SB2    1R/
          GCH    X1 
          SB3    X1 
          NE     B1,B3,PUSE5       IF A USELCM OPCODE 
 USESCM   GCH    X1                GET NEXT CHARACTER 
          SB3    X1 
          CWD 
          EQ     B1,B3,USESCM      IF A BLANK 
          EQ     B2,B3,USECOM 
          SA2    LORGTAB
 PUSE2    SA0    X2                SEARCH ORIGIN FOR USENXT 
          SB2    B6                BIT COUNT FOR PACKID 
          RJ     PACKID            GET BLOCK NAME 
          LX1    12 
 PUSE4    RJ     USENXT 
 OLJ      IFNE   .JOL,0 
          SA3    LORGTAB
          SB6    X3+3*22
          SX7    A2-B6
          NZ     X7,NOBINPO  IF NOT *CODE.* 
          SA3    PROGRAM
          ZR     X3,NOBINPO  IF BLOCK DATA
          UX3    B6,X3
          NZ     B6,PUSE4A   IF NOT MAIN PROGRAM
          SA3    PUSEA
          MX7    1
          SA7    A3 
          ZR     X3,NOBINPO  IF FIRST *USE CODE.* 
  
 PUSE4A   PLUG   AT=WRL.8,FROM=RJJOL
 OLJ      ENDIF 
          EQ     NOBINPO
  
 PUSE5    SA5    A5+B5             ADVANCE TO NEXT WORD 
          SB4    B7                RESET SHIFT COUNTER
 USECOM   GCH    X1 
          SB3    X1 
          CWD 
          SA2    CORGTAB
          NE     B2,B3,PUSE2
          SA1    =7L//
          SA0    X2 
          EQ     PUSE4
          SPACE  2
* 
* 
*         USENXT - CHANGE BLOCKS
* 
*         CALLING SEQUENCE -
*                   X1 = NAME OF NEW BLOCK LEFT JUSTIFIED IN BITS 
*                   18 - 59 WITH BLANK FILL 
*                   A0 = FWA OF TABLE (CORGTAB OR LORGTAB) WHICH
*                   CONTAINS NAME 
* 
          SPACE  4
          MOVSTART  8 
 USENXT   BSS    1
          SA2    A0-22
          MX0    42 
          BX1    X0*X1
 USENXT1  SA2    A2+22             LOOK FOR NEW BLOCK 
          BX2    X0*X2
          IX2    X2-X1
          NZ     X2,USENXT1        SENSE NEW BLOCK FOUND
          SA3    NFLAG
          SA4    TEXT.ADD 
          SA1    A2+B5             LOAD NEW NFLAG 
          BX6    X3 
          SA6    X4-4 
          SX7    A2+5 
          BX6    X1 
          SA7    A4 
          SA6    A3 
          BX7    X4 
          SA7    USEBB
          EQ     USENXT 
          MOVEND
          SPACE  4
          MOVSTART  1 
 USEBB    BSS    1
          MOVEND
          SPACE  2
          MOVSTART  5 
 USESTAR  BSS    1                 CHANGE BACK TO THE PREVIOUS RELOCATIO
          SA1    USEBB             BASE BY RESETTING TEXT.ADD AND EX- 
          SA2    TEXT.ADD          CHANGING NFLAGS. 
          SA3    NFLAG
          SA4    X1-4 
          BX7    X3 
          LX6    X4 
          SA7    A4 
          SA6    A3 
          BX7    X1 
          SA7    A2 
          EQ     USESTAR
          MOVEND
*** 
*         ORG MACRO PROCESSING
* 
  
 DATA.TXT                          ADDRESS OF DATA. TEXT TABLE
 K.       BSS    1                 SAVED RB AND ORGC OF DATA. 
 S.       BSS    1                 RB AND ORGC OF LAST ORG
 PORGT    EQU    SCRATCH
  
 PORG     MX7    60-12
          BX1    -X7*X5 
          NZ     X1,PORG1          IF ARGS
  
*         NO ARGS CASE RESET DATA. BLOCK ORG CTR AND FLUSH OUT OLD TEXT 
*         TABLE 
  
          SA1    DATA.TXT 
          SA2    K. 
          SA3    X1-2              POS CTR
          BX7    X2 
          SX0    B5 
          SA7    A3-B5           UPDATE ORG COUNTER 
          NZ     X3,PORG6          IF POS CTR " 0 
          IX7    X7-X0
          SA7    A7 
          EQ     PORG6
  
 PORG1    SA5    A5+B5             NEXT WORD
          SB4    B7 
          GCH    X1 
          RJ     NMLREF            GET NAME INFO ( RBT = WORD B OF NAME 
          RJ     NMLG              NEXT CHAR
          BX7    X2 
          SA7    PORGT             = 0 IF NAME,,X 
          NZ     X2,PORG2          IF NOT A , 
  
          SA1    DATA.TXT 
          SA2    X1-1        TABC 
          SA1    A2-B5       POSC 
          SA3    A1-B5       ORGC 
          BX6    X3 
          SB3    X2-2 
          GT     B3,PORGL1   IF TABC > 2
          SB3    X1-60
          ZR     B3,PORGL2   IF TABC = 2 AND POSC = 60
 PORGL1   MX7    59 
          IX6    X6-X7       K. = ORGC + 1 (NO SIGN EXTENSION)
 PORGL2   SA6    K. 
          EQ     PORG3
  
 PORG2    ZR     X3,PORG3          IF END OF LINE 
          SX2    X3-1R
          ZR     X2,PORG3          IF EOL 
          RJ     CONVERT           GET BIAS 
          SA2    RBT
          LX1    P.RA 
          IX6    X1+X2             ADD IN BIAS
          SA6    A2 
  
 PORG3    SA1    RBT
          BX2    X1 
          LX1    59-P.RL-1
          MX0    60-L.DIMP
          NG     X1,PORG4          IF IN COMMON 
          AX2    P.DIMP 
          BX3    -X0*X2 
          NZ     X3,PORG4          IF NOT A USEAGE DEFI ED VAR
          SA3    PORGT
          ZR     X3,PORG4          IF SECOND OCCURANCE OF UDV 
  
*         FIRST OCCURANCE OF A UDV - SWITCH TO DATA. BLOCK
  
          SA1    TEXT.ADD 
          SA2    NFLAG
          SA3    DATA.TXT 
          SA4    X3-4              NFLAG(DATA.) 
          BX6    X1 
          LX7    X2 
          SA6    USEBB             SAVE TEXT TABLE ADDR OF LAST BLOCK 
          SA7    X1-4              AND NFLAG
          BX6    X3 
          LX7    X4 
          SA6    A1                NEW TEXT.ADD 
          SA7    A2                NEW NFLAG
          SB3    60 
          EQ     NOBINPO
  
*         NOT THE FIRST OCCURANCE OF A UDV
*         SET TEXT.ADD TO THE RB INDICATED BY THE VAR 
*         AND FORCE OUT THE OLD TEXT TABLE
  
 PORG4    SA1    RBT
          MX0    60-L.RB
          AX1    P.RB 
          BX3    -X0*X1            RB 
          SA2    =22.P0 
          PX3    X3 
          AX1    P.RA-P.RB
          SX7    X1                SAVE RA
          AX1    P.RL-P.RA
          DX2    X2*X3             22*RB
          MX0    60-L.RL
          BX1    -X1+X0            INDEX TO LORGTAB OR CORGTAB
          SA1    X1+LORGTAB+1 
          SX2    X2+5 
          IX6    X1+X2             NEW TEXT.ADD = CORGTAB(RL)+RB*22+5 
  
          SA1    X6-3              RB AND ORG CTR 
          SA2    A1+B5             POS CTR
          MX0    60-18
          BX3    X0*X1             EXTRACT LOADER RB CODE 
          IX7    X3+X7
          SA6    TEXT.ADD          UPDATE TEXT ADD
          SA7    S.                SAVE VALUE OF ORG CTR FOR REPI PROCES
          NZ     X2,PORG5          IF POS CTR " 0 
          SX0    B5 
          IX7    X7-X0             DECREMENT ORG CTR FOR WRTEXT 
 PORG5    SA7    A1                SAVE ADDR OF ORG 
 PORG6    RJ     FOTEXT            FORCE OUT OLD TABLE
          SB3    60 
          EQ     NOBINPO
          EJECT 
*** 
*         PGNAME - PROCESS "GNAME" MACRO CALL 
* 
 PGNAME   SX1    B3-1RE 
          ZR     X1,L3.BJP         IF GE BI,BJ
  
          SA1    A5+B5
          SX2    1R$
          RJ     RSC               REMOVE POSSIBLE $
          AX6    B7,X6             REMOVE TRAILING BLANKS 
          LX4    B7,X6             LEFT JUSTIFY TO BIT 42 
 PGNAME1  WR1WD  ,INITL            WRITE WORD TO LGO FILE 
          SPACE  3
*** 
*         PFMT - PROCESS FMT MACRO CALL 
* 
 PFMT     SX1    1R.-1R 
          LX1    54 
          IX5    X5-X1             CHANGE LEADING . TO A BLANK
          BX4    X0*X5             6L NNN 
          EQ     PGNAME1           GO WRITE THE WORD TO THE LGO FILE
          SPACE  3
* 
*         SUB 
* 
          MOVSTART 1
 DELAY    BSSZ   1           DELAY FLAG 
          MOVEND
  
  
          MOVSTART 3
 PSUB     SB4    B4-6*2      1*ST CHARACTER OF F.P. NAME
          MX1    0
          SB2    B0 
          MX4    7*6
          SX7    B5 
          RJ     PACKID      GET F.P. NAME
          EQ     PSUB0
          MOVEND
  
 PSUB0    SA2    SYM1 
          SX0    -B5
          LX1    12 
          SA2    X2-4        FIRST F.P. IN SYMTAB 
          BX3    X4*X1
          SB2    B5+B5
  
 PSUB10   BX6    X4*X2       LOOP FOR F.P. ENTRY
          SX0    X0+B5       INCREMENT F.P. SYMTAB ORDINAL
          BX6    X6-X3
          SA2    A2-B2       NEXT SYMTAB ENTRY
          NZ     X6,PSUB10   IF NOT THIS ONE
  
          SA4    TEXT.ADD    CURRENT BLOCK
          SB3    A5 
          SA3    A2+B5       WORD B 
          SA5    X4-2        CURRENT BLOCK POSITION COUNTER 
          BX2    X3 
          IX6    X5-X7       SHIFT = 29, 14 OR -1 
          SA7    FFLAG       INDICATE FORCE UPPER 
          LX2    59-P.NFU 
          SA4    A5-B5       CURRENT BLOCK ORG COUNTER
          AX6    59 
          AX2    11 
          BX6    X6*X7
          SX5    X5+2000B    SHIFT = 2030, 2015 OR 2000 
          LX7    P.NFU
          IX5    X5-X6       SHIFT = 2030, 2015 OR 1777 
          BX7    X3+X7       SET *P.NFU* BIT
          SX6    X4 
          LX0    42          POSITION F.P. ORDINAL
          SA7    A3          RESET WORD B 
          MX4    12 
          LX5    -12         POSITION SHIFT 
          BX7    X1+X6       F.P. NAME + ORGC 
          BX2    X4*X2
          SA3    DELAY
          IX5    X5+X6       SHIFT +  ADDRESS (ORGC)
          BX3    X3-X7       =0 IF DELAY NECESSARY, "0 IF NOT 
          SX6    B0 
          BX4    -X3
          SA7    A3          RESET DELAY
          IX6    X6+X4
          SB2    B1-1R
          BX4    X3+X6       =0 IF DELAY NECESSARY, -0 IF NOT 
          IX5    X5+X0       SHIFT + F.P. ORDINAL + ADDRESS (ORGC)
          SA3    LORGTAB
          BX2    X4*X2       12 BIT MASK IF NOT FIRST F.P. AND NOT DELAY
          SA0    X3 
          BX5    X5-X2
          RJ     USENXT      EXCHANGE CURRENT BLOCK WITH FP BLOCK 
          ZR     B1,PSUB20   IF NO CONSTANT 
          ZR     B2,PSUB20   IF A BLANK 
          BX6    X5 
          MX0    54 
          SA5    B3 
          GCH    X3          GET FIRST CHARACTER OF CONSTANT
          CWD 
          RJ     CONVERT     CONVERT CONSTANT 
          MX0    -18
          BX1    -X0*X1 
          LX1    18 
          BX5    X1+X6       SHIFT + F.P. NUMBER + CA +  ADDRESS (ORGC) 
  
 PSUB20   BX4    X5 
          SB1    60 
          SB6    PSUB30      RETURN ADDRESS 
          EQ     WRTEXT 
  
          MOVSTART 4
 PSUB30   SX1    B5+B5
          IX6    X6+X1
          SA6    A3 
          RJ     USESTAR     CHANGE F.P. BLOCK BACK TO ORIGINAL BLOCK 
          SA1    RJTFLAG
          NZ     X1,L3.RJTE  IF PROCESSING AN *RJT* 
          EQ     INITL       NEXT COMPS INSTRUCTION 
          MOVEND
          SPACE  2
* 
*         IOM MACRO 
* 
  
 PIOM     MX6    0
          SB1    NNAME             FWA
          SB2    FNAME+1           LWA+1
 PIOC     SA6    B1                CLEAR SCRATCH CELLS
          SB1    B1+B5
          LT     B1,B2,PIOC 
          SA5    A5+B5             NEXT WORD
          SB4    B7                RESET BIT COUNTER
          RJ     NMLG              EXAMINE FIRST CHARACTER
          ZR     X2,PIOMA          IF A NULL FIELD
          SX1    X3-1R? 
          ZR     X1,PIOM11         IF LCM RESIDENT
          SX1    X3-1R- 
          ZR     X1,PIOMB          IF AN IOM -1 
          PL     X1,PIOM0          IF OTHER SPECIAL CHARACTER 
          SX1    X3-1R0 
          PL     X1,PIOMC          IF A DIGIT 
  
 PIOM0    BX1    X3 
          RJ     NMLREF            PROCESS THE NAME 
          SX2    B1-1R, 
          NZ     X2,PIOM7          IF  NOT ENDED BY A COMMA 
 PIOM1    RJ     NMLG 
          ZR     X2,PIOM2          IF A NULL BIAS FIELD 
          RJ     CONVERT           CONVERT THE BIAS 
          BX6    X1 
          SA6    BIASN             SAVE THE BIAS
  
          RJ     NMLG              BYPASS THE COMMA 
          NZ     X2,PIOM7          IF END OF IOM
 PIOM2    RJ     NMLG 
          ZR     X2,PIOM3          IF A NULL TYPE FIELD 
          RJ     CONVERT
          LX1    48                POSITION TYPE FIELD
          BX6    X1 
          SA6    TNAME             SAVE THE TYPE
  
          RJ     NMLG 
          NZ     X2,PIOM7          IF END OF IOM
 PIOM3    RJ     NMLG 
          ZR     X2,PIOM4          IF A NULL COUNT FIELD
          RJ     CONVERT           CONVERT THE COUNT
          BX6    X1 
          SA6    ZZN               SAVE THE COUNT 
  
          RJ     NMLG 
          NZ     X2,PIOM7          IF END OF IOM
 PIOM4    MX6    0
          RJ     NMLG 
          ZR     X2,PIOM5          IF NO B59 FLAG 
          SX6    X3-1R0 
          LX6    59 
          SA6    Z1N               SAVE B59 FLAG
          RJ     NMLG 
          NZ     X2,PIOM7          IF END OF IOM
 PIOM5    RJ     NMLG 
          ZR     X2,PIOM6          IF A NULL B57 FIELD
          SX3    X3-1R0 
          LX3    57 
          BX6    X3+X6             COMBINE BIT 57 AND BIT 59
          SA6    Z1N               STORE THE RESULT IN Z1N
  
          RJ     NMLG 
          NZ     X2,PIOM7          IF END OF IOM
 PIOM6    SA1    VNAME
          SA2    RBT
          BX6    X1 
          LX7    X2 
          SA6    NNAME             SAVE VNAME 
          SA7    Z3N
          GCH    X1 
          CWD 
          SX3    X1-1R0 
          PL     X3,PIOMD          IF A DIGIT 
          RJ     NMLREF            PROCESS BASE2
          SA1    VNAME
          SA2    NNAME
          BX6    X1 
          LX7    X2 
          SA6    A2                SWAP VNAME AND NNAME 
          SA7    A1 
          SA3    Z3N
          BX6    X3 
          SA6    RBT               RESTORE RBT
  
 PIOM7    SA1    Z1N               B59, B57 
          SA2    TNAME             TYPE 
          SA3    ZZN               COUNT OR BIAS2 
          BX6    X1+X2             B59, B57, TYPE 
          LX3    24                POSITION COJNT FIELD 
          SA1    NNAME
          IX7    X1+X3             BASE2 + BIAS2 ( COUNT )
          SA2    VNAME
          SA3    BIASN
          SA1    FPN               FP FLAG BIT
          IX3    X2+X3             BASE + BIAS
          BX1    X6+X1             B59,FP, B57, TYPE
          BX7    X7+X1             B59,FP, B57, TYPE, COUNT 
          BX4    X7+X3             B59,FP,B57,TYPE,COUNT,ADDRESS
 PIOM8    SB6    L4.CKRB           RETURN FOR RELOCATION
          SA3    Z2N               NO BASE INDICATOR
          PL     X3,PIOM9          IF A BASE WAS PRESENT
          SB6    INITL             RETURN ADDRESS FOR NO RELOCATION 
 PIOM9    SB1    60                60 BITS OF TEXT
          SA2    RBT
          BX6    X2 
          SA6    RBTEMP            RESTORE RBTEMP 
          SA1    FNAME
          ZR     X1,WRTEXT         IF NO LCM RELOCATION 
          SB6    PIOM10            RETURN FOR LCM RELOCATION
          SX1    X1-1 
          SX2    2                 COMMON RELOCATION
          LX2    P.RL 
          LX1    P.RB 
          BX6    X2+X1
          SA6    RBTEMP            SETUP RELOCATION WORD
          EQ     WRTEXT 
  
 PIOM10   SA3    FNAME             BLOCK ORDINAL
          SX2    X3-1 
          RJ     ALR               ADD LCM RELOCATION 
          EQ     INITL
  
 PIOM11   RJ     NMLG 
          RJ     CONVERT           CONVERT MMM TO BINARY
          BX6    X6-X6
          LX7    X1 
          SA6    VNAME             NO BASE ADDRESS
          SA7    FNAME             BLOCK ORDINAL
          EQ     PIOM1
  
 PIOMA    MX6    1                 FORMAL PARAMETER IF NULL BASE
          LX6    -1                BIT 58 = FP FLAG 
          SA6    FPN
          EQ     PIOM1
  
 PIOMB    MX4    59                SET VALUE OF -1
          EQ     PIOM8
  
 PIOMC    RJ     CONVERT           CONVERT CONSTANT IN BASE FIELD 
          MX6    1
          SA6    Z2N               FLAG NO NAME FIELD 
          GCH    X2                ADVANCE OVER THE COMMA 
          EQ     PIOM1             GO PROCESS BIAS
  
 PIOMD    BX3    X1 
          RJ     CONVERT
          SA3    BIASN
          LX1    6
          IX6    X1+X3
          SA6    A3                COMBINE FO ORD + OFFSET
          EQ     PIOM7
  
* 
*         EIO MACRO 
* 
          MOVSTART  7 
 PEIO     SA5    A5+B5       NEXT WORD
          SB4    B7          RESET BIT COUNT
          CWD 
          GCH    X3 
          SX2    X3-1R- 
          MX4    0
          NZ     X2,PEIO1    IF NOT A -0
          MX4    60 
 PEIO1    SB1    60 
          SB6    INITL             RETURN ADDRESS FROM WRTEXT 
          EQ     WRTEXT 
          MOVEND
          SPACE  4
* 
*         DELAY 
* 
 PFILE    EJECT 
**        PFILE - PROCESS *FILCRM/FIL7RM* MACRO.
* 
*         EXTRACTS LFN, BFS AND MRL FROM *FIL-RM* MACRO.  COMPUTES FWA
*         FIT, FWB AND WSA.  ENTERS VALUES IN SKELETON FIT AND WRITES 
*         FIT TO BINARY OUTPUT FILE.  PREPARES REPL (4300) TABLE FOR
*         PADDING THE REMAINING FIT LENGTH WITH ZERO FILL, AND WRITES 
*         TABLE TO BINARY OUTPUT FILE.
* 
* 
*         ENTRY  REGISTERS = STANDARD *GCH* SETUP.
*                (ILINE) = *FILCRM/FIL7RM* MACRO CALL.
* 
*         EXIT   FIT AND REPL TABLE WRITTEN TO BINARY OUTPUT FILE.
*                (ORGC) INCREMENTED BY LENGTH OF FIT, BFS AND WSA.
* 
*         USES   ALL. 
* 
*         CALLS  CONVERT, CW, CWD, GCH, NMLG, PACKID, RL=, WRITEW,
*                WRSEQ, WR1WD.
  
  
          QUAL   PFILE
  
  
 PFILE    SUBR               ** ENTRY/EXIT ** 
  
*         GET ARG 1 = LOGICAL FILE NAME (LFN).
  
          GCH    X1 
          SB2    B6 
          RJ     PACKID 
          SB3    B6-B3
          AX1    B3          REMOVE BLANK FILL AND SPECIAL CHAR 
          SB3    B3+12
          SX2    B5          CIO COMPLETE BIT (CMPLT) 
          LX1    B3          LEFT JUSTIFY LFN 
          BX6    X1+X2       LFN, CMPLT BIT 
          SA6    FIT6A+O.LFN LFN TO CRM FIT 
  
*         GET ARG 2 = BUFFER LENGTH (BFS).
  
          GCH    X3 
          CWD 
          RJ     CONVERT
          BX6    X1 
          SA6    T.BFS       TEMP SAVE BFS
  
*         GET ARG 3 = MAX RECORD LENGTH (MRL).
  
          RJ     NMLG        SKIP COMMA 
          GCH    X3 
          CWD 
          RJ     CONVERT
          BX2    X1          (X2) = MRL(CHARACTERS) 
          CW     X3,X1       (X3) = MRL(WORDS)
          MX0    -27
          SA4    T.BFS       (X4) = BFS 
  
*         GET CURRENT PROGRAM-RELATIVE ADDRESS (ORGC).
  
          SA1    TEXT.ADD 
          SA5    X1-3 
          BX6    -X0*X5 
          LX5    X6          (X5) = 33/0, 9/RELOC BASE, 18/PROG-REL ADDR
          SA6    T.ORGC      TEMP SAVE RELOCATED FWA FIT
          SB1    1           (B1) = 1 
  
#RM       IFEQ   OT#RM,7
  
          SA1    =XOT.RM
          ZR     X1,PF3      IF CRM OBJECT MODE (*FILCRM* MACRO)
  
  
**        FORM 7RM (SCOPE 2) FIT AND WRITE TO BINARY OUTPUT FILE. 
  
*         FILL IN REPL (4300) TABLE SKELETON. 
  
          SA1    REPL7
          SA6    PREPIC+1    ZERO WORD SOURCE ADDR TO REPL TABLE
          IX7    X1+X6
          SA7    A6+B1       REPL LENGTH, DESTIN ADDR TO REPL TABLE 
  
*         FILL IN FIT SKELETON. 
  
          SX0    L.FIT7 
          IX5    X5+X0       FWB = (ORGC) + L.FIT7
          MX6    0           PRESET NO MRL OR WSA 
          MX7    0           PRESET NO RELOCATION 
          ZR     X2,PF2      IF MRL=0 OR OMITTED (NO WSA) 
          IX5    X5+X4       WSA = FWB + BFS
          SX6    X5          (X6) = EXTRACT WSA 
          IX5    X5+X3       NEXT ORG = WSA + MRL(WORDS)
          IX0    X3+X3       MRL*2
          LX3    3              *8
          IX0    X3+X0          *10 
          IX1    X0-X2       UNUSED CHARS = 10 * MRL(WORDS) - MRL(CHARS)
          IX0    X1+X1       UCH*2
          LX1    2              *4
          IX0    X1+X0       UNUSED BIT COUNT (UBC) = 6 * UNUSED CHARS
          LX3    36-3 
          BX6    X6+X3
          LX0    54 
          BX6    X6+X0       6/UBC, 18/MRL(WDS), 15/0, 21/WSA 
          MX7    1           =2S58
          LX7    60-7*4-58   RELOCATE WSA IN 7TH WORD 
 PF2      SA6    FIT7A+O.MRLWSA 
          SB2    L.FIT7A     (B2) = TEXT LENGTH 
          BX6    X5 
          SA6    T.NXTORG    TEMP SAVE UPDATED (ORGC) 
  
*         WRITE FIT AND REPL TO BINARY OUTPUT FILE. 
  
          MX6    0           (X6) = NO INCREMENT
          SA4    FIT7A       (A4,X4) = FWA FIT
          RJ     PFA         FIT TO BINARY OUTPUT FILE
          SA1    =XFV.LGO 
          ZR     X1,PF10      IF BINARY OUTPUT OPTION OFF (B=0) 
          WRITEW F.LGO,PREPIC,3    REPL (4300) TABLE TO BIN OUTPUT FILE 
          SB5    1
          EQ     PF10 
  
#RM       ENDIF 
  
  
**        FORM CRM (NOS, NOS/BE) FIT AND WRITE TO BINARY OUTPUT FILE. 
* 
*         ENTRY  (X2) = MRL(CHARACTERS) 
*                (X3) = MRL(WORDS)
*                (X4) = BFS 
*                (X5) = 33/0, 27/(ORGC) 
*                (B1,B5) = 1
  
*         FILL IN REPL (4300) TABLE SKELETON. 
*         NOTE THAT THE REPL LENGTH CAUSES ALL OF THE SKELETON FIT, 
*         EXCEPT SECTION (A), TO BE ZERO FILLED AT LOAD TIME.  THEN FIT 
*         SECTIONS (B) AND (C) WILL BE LOADED OVER THE ZERO FILL. 
*         THIS IS FASTER THAN ISSUING (AND FORCING LOADER TO PROCESS) 
*         THREE SEPARATE REPL TABLES FOR THE REQUIRED ZERO FILL.
  
 PF3      SA1    REPL6
          SX0    O.ZERO6
          IX6    X5+X0
          IX7    X5+X1
          SA6    PREPIC+1    ZERO WORD SOURCE ADDR TO REPL (4300) TABLE 
          SA7    A6+B1       REPL LENGTH, DESTIN ADDR TO REPL TABLE 
  
*         FILL IN FIT SECTION (A).
  
          SX0    L.FIT6 
          IX5    X5+X0       FWB = (ORGC) + L.FIT6
          MX6    0           PRESET NO FWB
          ZR     X4,PF4      IF NO CIO BUFFER (BFS=0) 
          SX6    X5          SET FWB
 PF4      SA6    FIT6A+O.FWB
  
*         FILL IN FIT(B) AND FIT(C).
  
          IX5    X5+X4       WSA = FWB + BFS
          IX7    X5+X3       NEXT ORG = WSA + MRL(WORDS)
          SA7    T.NXTORG    TEMP SAVE UPDATED (ORGC) 
          LX2    36 
          BX6    X4          BFS
          LX7    X2          MRL
          SA6    FIT6B+O.BFS-O.FIT6B
          SA7    FIT6B+O.MRL-O.FIT6B
          MX6    2           =6S57
          SX7    B0          PRESET NO MRL OR WSA 
          LX6    30-57       (EO) = 6S30  -- PRESET NO WSA
          ZR     X2,PF5      IF NO WSA (MRL=0)
          SX0    X5 
          BX6    X6+X0       SET EO, WSA
          IX7    X2+X0       SET MRL, WSA 
 PF5      SA6    FIT6B+O.EOWSA-O.FIT6B
          SA7    FIT6C
  
*         FIT(A) TO BINARY OUTPUT FILE. 
  
          SB2    L.FIT6A     (B2) = TEXT LENGTH 
          MX6    0           (X6) = NO INCREMENT
          BX7    X7-X7       (X7) = PRESET NO RELOCATION
          ZR     X4,PF6      IF NO CIO BUFFER (BFS=0) 
          MX7    1           =2S58
          LX7    60-2*4-58   (X7) = SET FWB (2ND WORD) RELOCATION 
 PF6      SA4    FIT6A       (A4,X4) = TEXT FWA 
          RJ     PFA         FIT(A) TO BINARY OUTPUT FILE 
  
*         REPL (4300) TABLE TO BINARY OUTPUT FILE.
  
          SA1    =XFV.LGO 
          ZR     X1,PF7      IF BINARY OUTPUT OPTION OFF (B=0)
          WRITEW F.LGO,PREPIC,3 
  
*         FIT(B) TO BINARY OUTPUT FILE. 
  
 PF7      SA1    FIT6C
          MX7    0           (X7) = PRESET NO WSA RELOCATION
          SX2    X1 
          ZR     X2,PF8      IF NO WSA
          MX7    1           =2S58
          LX7    60-6*4-58   (X7) = SET WSA (6TH WORD) RELOCATION 
 PF8      SB2    L.FIT6B     (B2) = TEXT LENGTH 
          SA4    FIT6B       (A4,X4) = TEXT FWA 
          SX6    O.FIT6B     (X6) = FIT(B) INCREMENT
          RJ     PFA         FIT(B) TO BINARY OUTPUT FILE 
  
*         FIT(C) TO BINARY OUTPUT FILE. 
  
          SA4    FIT6C       (A4,X4) = TEXT FWA 
          SX6    O.FCLEXT    (X6) = FIT(C) INCREMENT
          ZR     X4,PF10     IF NO WSA, OMIT FIT(C) 
          MX7    1           =2S58
          SB2    B1          (B2) = TEXT LENGTH 
          LX7    60-1*4-58   (X7) = SET WSA (1ST WORD) RELOCATION 
          RJ     PFA         FIT(C) TO BINARY OUTPUT FILE 
  
*         UPDATE (ORGC).
  
 PF10     SA1    T.NXTORG 
          SA2    TEXT.ADD 
          MX3    1           =4000BS48 (TEXT TABLE CODE)
          LX6    X1 
          BX7    X3+X6
          SA7    X2 
          SA6    X2-3 
          EQ     EXIT.
 PFILE    SPACE  4,8
**        PFA - SUPPORT SUBROUTINE FOR *PFILE*. 
* 
*         SETS BINARY OUTPUT ADDRESS TO (T.ORGC) + (X6).
*         WRITES 1-15 WORDS OF TEXT TO THE CURRENT TEXT TABLE.
*         WRITES TABLE TO THE BINARY OUTPUT FILE. 
* 
*         ENTRY  (A4,X4) = NEW TEXT FWA.
*                (X6) = (T.ORGC) INCREMENT. 
*                (X7) = RELOCATION BYTE WORD. 
*                (B2) = TEXT LENGTH.
* 
*         EXIT   (B1,B5) = 1. 
*                NEW TEXT WRITTEN TO BINARY OUTPUT FILE.
*                (ORGC) IN TEXT TABLE = LWA WRITTEN + 1.
* 
*         USES   ALL. 
* 
*         CALLS  FOTEXT, WRSEQ. 
  
  
 PFA      SUBR               ** ENTRY/EXIT ** 
          SA1    T.ORGC 
          SA2    TEXT.ADD 
          IX6    X1+X6
          MX1    1           =4000BS48 (TEXT TABLE CODE)
          SA6    X2-3        UPDATE (ORGC)
          BX6    X1+X6
          SA6    X2          NEW TEXT TABLE HEADER
          SB5    1
          SX6    B2          (X6) = TEXT LENGTH 
          RJ     WRSEQ       NEW TEXT TO TEXT TABLE 
          RJ     FOTEXT      TEXT TABLE TO BINARY OUTPUT FILE 
          SB1    1
          EQ     EXIT.
 PFILE    SPACE  4,8
*         TEMPORARY STORAGE LOCATIONS.
  
 T.BFS    =      SCRATCH+8   BUFFER SIZE (WORDS)
 T.ORGC   =      SCRATCH+9   33/0,9/RELOC BASE,18/START ADDR
 T.NXTORG =      SCRATCH+10  33/0,9/RELOC BASE,18/NEXT START ADDR 
  
  
  
**        CRM (NOS, NOS/BE) FIT SKELETON. 
  
 FIT6A    BSS    0
          LOC    0
 O.LFN    VFD    42/**,18/0        LOGICAL FILE NAME (LFN), 0L FORMAT 
 O.FWB    VFD    36/0,6/L.FIT6-L.FCLX-5,18/** 
                             (FIT LENGTH - 5) + FWA CIRCULAR BUFFER 
 O.ZERO6  DATA   0                 ZERO WORD FOR REPLICATION
          LOC    *O 
 L.FIT6A  =      *-FIT6A
*         BSSZ   7                 ZEROS SUPPLIED BY REPLICATION
 FIT6B    BSS    0
          LOC    12B
 O.FIT6B  BSS    0
          VFD    36/0,2/3,22/0     LABEL TYPE (LT)=ANY
          VFD    25/0,2/2,3/2,30/0 OPEN FLAG (OF)=N, CLOSE FLAG (CF)=N
 O.MRL    VFD    24/**,36/0        MAXIMUM RECORD LENGTH (MRL)
          VFD    2/0,2/3,56/0      DAYFILE CONTROL (DFC)=3
          DATA   0
 O.EOWSA  VFD    27/0,3/6,12/0,18/**  ERR OPT (EO)=6, FWA WRK STOR (WSA)
          DATA   0
 O.BFS    VFD    42/0,18/**        CIRCULAR BUFFER SIZE (BFS) 
          DATA   0,0,0,0
          VFD    20/0,4/1,36/0       FORTRAN GENERATED FIT FLAG 
          LOC    *O 
 L.FIT6B  =      *-FIT6B
*         BSSZ   O.FCLEXT-O.BFS    ZEROS SUPPLIED BY REPLICATION
 FIT6C    BSS    0
          LOC    L.FIT6-L.FCLX
 O.FCLEXT VFD    24/**,18/0,18/**  MAX REC LEN (MRL), FWA WRK STO (WSA) 
          LOC    *O 
  
 REPL6    VFD    18/L.FIT6-L.FIT6A,15/1,9/0,18/L.FIT6A
  
  
**        7RM (SCOPE 2) FIT SKELETON. 
  
#RM       IFEQ   OT#RM,7
  
 FIT7A    BSS    0
          LOC    0
 O.ZERO7  DATA   0           ZERO WORD FOR REPLICATION
          DATA   0
          VFD    24/0,2/2,4/1,2/0,28/0   (OF)=N,(LT)=UNLABELED
          BSSZ   3
 O.MRLWSA VFD    6/**,18/**,15/0,21/**   (MRL - UBC,WORDS), (WSA) 
          DATA   0
          VFD    14/0,4/1,42/0       FORTRAN GENERATED FIT FLAG 
          LOC    *O 
 L.FIT7A  =      *-FIT7A
  
 REPL7    VFD    18/L.FIT7-L.FIT7A,15/1,9/0,18/L.FIT7A
  
 #RM      ENDIF 
 PFILE    SPACE  4,2
          QUAL   *
 PFILE    =      /PFILE/PFILE 
 NAME     EJECT 
*** 
*         NAME
* 
 NNAME    EQU    SCRATCH
 VNAME    EQU    SCRATCH+1
 TNAME    EQU    SCRATCH+2
 RBT      EQU    SCRATCH+3
 BIASN    EQU    SCRATCH+4
 FPN      EQU    SCRATCH+5
 ZZN      EQU    SCRATCH+6
 Z1N      EQU    SCRATCH+7
 Z2N      EQU    SCRATCH+8
 Z3N      EQU    SCRATCH+9
 FNAME    EQU    SCRATCH+10 
          SPACE  3
*** 
*         GET REFERENCED NAME FOR NAMELIST MACRO
* 
          MOVSTART  16B 
 NMLREF   ENTRY. *
          SB3    X1                FIRST CHAR 
          SB2    X1-1R? 
          ZR     B2,NMLR.1   IF ?MMM SYMBOL 
          SB2    B6                B2 = 6 
          RJ     REF
 NMLR.2   SA4    RBTEMP 
          BX6    X3 
          LX7    X4 
          SA6    VNAME             VNAME = RA 
          SA7    RBT               RBT = RBTEMP = WORD B OF SYMTAB
          MX6    0
          SA6    A4                RBTEMP = 0 
          EQ     NMLREF 
 NMLR.1   GCH    X3 
          CWD 
          RJ     CONVERT     MMM OF ?MMM
          SX2    X1-1 
          SX1    2           COMMON RELOCATION
          LX2    P.RB 
          LX1    P.RL 
          BX6    X2+X1
          SA6    RBTEMP 
          MX3    0
          EQ     NMLR.2 
  
          MOVEND
          SPACE  3
*** 
*         NMLG - GET NEXT CHAR FOR NAME MACRO CALL PROCESSOR
* 
          MOVSTART  4 
 NMLG 
          GCH    X3                GET CHARACTER
          CWD                      CHECK WORD 
          SX2    X3-1R, 
          EQ     NMLG 
          MOVEND
          SPACE  3
*** 
*         PNAME - PROCESS "NAME" MACRO CALL 
* 
 PNAME    SA5    A5+B5             NEXT WORD
          SB4    B7 
          MX6    0
          SB1    NNAME             FWA
          SB2    FNAME+1           LWA+1
 +        SA6    B1                CLEAR OUT SCRATCH CELLS
          SB1    B1+B5
          LT     B1,B2,*
  
          GCH    X1 
          RJ     NMLREF            GET NAME INFO
          BX7    X1 
          SA7    FNAME             SAVE NAME
          SX2    1R$
          RJ     RSC               REMOVE TRAILING BLANKS AND POSSIBLE $
          AX6    B7,X6             REMOVE TRAILING BLANKS 
          LX6    B7,X6             REPOSITION NAME TO TOP OF WORD 
          SA6    NNAME             SAVE 
          SB7    54 
          GCH    X3 
          RJ     CONVERT           GET AND
          BX6    X1                SAVE TYPE
          SA6    TNAME
  
          RJ     NMLG              NEXT CHAR
          NZ     X2,PNAME4         IF NO MORE PARAMS
          RJ     NMLG 
          ZR     X2,PNAME2         IF NOT EQUIVALENCED
          BX1    X3 
          RJ     NMLREF            GET BASE INFO
          RJ     NMLG 
          RJ     CONVERT           GET BIAS 
          BX6    X1 
          SA6    BIASN
  
 PNAME2   RJ     NMLG              NEXT CHAR
          NZ     X2,PNAME4         IF NOT A COMMA 
          RJ     NMLG 
          ZR     X2,PNAME2A        IF NO FP ORDINAL 
          RJ     CONVERT
          SX6    B5 
          LX6    28 
          BX6    X1+X6
          SA6    VNAME             SET FP BIT + ORDINAL NUMBER
          SA6    FPN
          RJ     NMLG 
          NZ     X2,PNAME4         IF NOT DIMENSIONED 
 PNAME2A  RJ     NMLG 
          ZR     X2,PNAME4         IF NO NDIM FIELD PRESENT 
          SX6    X3-1R0 
          SA6    ZZN               SAVE CONVERTED NUMBER OF DIMENSIONS
          RJ     NMLG 
          NZ     X2,PNAME4         IF NO MORE PARAMS
          RJ     NMLG              NEXT CHAR
          SX1    X3-1R
          ZR     X3,PNAME4         IF A 0 CHAR
          ZR     X1,PNAME4         IF A BLANK 
  
          RJ     CONVERT
          BX7    X1 
          SA7    Z1N               D1 
          RJ     NMLG 
          NZ     X2,PNAME4         IF NO D2 
          RJ     NMLG              FIRST CHAR OF CONSTANT 
          RJ     CONVERT
          BX6    X1 
          SA6    Z2N
          RJ     NMLG 
          NZ     X2,PNAME4         IF NO D3 
          RJ     NMLG              FIRST CHAR OF CONSTANT 
          RJ     CONVERT
          BX6    X1 
          SA6    Z3N
  
*         NOW OUTPUT THE BINARY 
  
 PNAME4   SA3    NNAME             NAME 
          SA2    TNAME             TYPE 
          MX0    60-3 
          BX2    -X0*X2            SAVE TYPE VALUE
          SA1    ZZN               NUMBER OF DIMENSIONS 
          LX1    6
          BX6    X3+X2
          IX4    X1+X6             COMBINE ALL THREE
          WR1WD                    WRITE NAME WORD
  
          SA1    VNAME
          SA2    BIASN
          IX2    X1+X2             SOURCE ADDR OF NAMELIST VARIABLE 
          SA3    TNAME
          AX3    3
          LX3    29                MOVE POSSIBLE LCM BIT TO PROPER SPOT 
          BX2    X3+X2
          SA3    Z1N               D1 
          LX3    30 
          BX4    X2+X3             D1 + ADDRESS OF ITEM 
          WR1WD                    WRITE THE 2ND WORD 
          SA1    RBT               (X1) = RELOCATION INFO FOR VARIABLE
          SA2    TEXT.ADD 
          LX1    59-P.RL-1
          SA3    FPN
          NZ     X3,PNAME7         IF AN FP, NO RELOCATION
          PL     X1,PNAME6         IF LOCAL ADD LOWER RELOCATION BYTE 
          LX1    L.RL+P.RL-P.RB 
          SA3    X2-3              LINK IT TO COMMON REFERENCE CHAIN. 
          MX0    60-L.RB
          SA2    =20000000000000000026B 
          BX1    -X0*X1 
          PX1    X1,B0
          MX7    1
          DX1    X1*X2
          LX3    30 
          SA2    CORGTAB
          BX7    X3+X7
          SA4    FREEMEM
          IX1    X1+X2
          SA5    MEMEND 
          MX0    60-18
          SA2    X1 
          SX6    X4+B5
          BX3    -X0*X2 
          IX5    X5-X4
          BX2    X0*X2
          NG     X5,STOVER         SENSE STORAGE OVERFLOW 
          SA6    A4 
          BX7    X7+X3
          IX6    X4+X2
          SA7    X4 
          SA6    A2 
          EQ     PNAME7 
 PNAME6   SA3    X2+B5
          SX1    RL$L              LOWER PROGRAM RELOCATION 
          IX6    X1+X3
          SA6    A3 
 PNAME7   SA3    ZZN               NDIMS
          AX3    1
          ZR     X3,INITL          IF 0 OR 1 DIMENSIONS 
          SA2    Z3N               D3 
          SA1    Z2N               D2 
          LX2    30 
          BX4    X1+X2             D2 + D3
          SB1    60 
          SB6    INITL             RETURN ADDRESS FOR WRTEXT
          EQ     WRTEXT 
          EJECT 
*** 
*         PENTR. - PROCESS ENTR MACRO 
* 
          MOVSTART  1 
 ENTRRP   RELOC  (,U,B,,U,U,B,L,B)
          MOVEND
          SPACE  2
          MOVSTART  10
 ENTRCP   BSSZ   1                 ENTR. CODE PROTOTYPE 
          SA2    0                 (*+3)
          BX6    X2 
          SA6    0                 (FTNNOP.)
          RJ     0                 (*+1)
          BSSZ   1
          EQ     0                 (ENTRY.+1) 
          EQ     0                 (*+1)
          SA1    0                 (NOPS.)
          SA2    0                 (NAME) 
          BX6    X1 
          LX7    X2 
          SA6    0                 (FTNNOP.)
          SA7    0                 (ENTRY.) 
          RJ     0                 (*+1)
          BSSZ   1
          BSS    0
 ENTRLP   EQU    *-ENTRCP 
          MOVEND
          SPACE  2
          MOVSTART  1 
 ENTRRN   RELOC  (,U,B) 
          MOVEND
          SPACE  2
          MOVSTART  4 
 ENTRCN   BSSZ   1                 ENTR. CODE PROTOTYPE (NO ARGUMENTS)
          SA1    0                 (NAME) 
          BX6    X1 
          SA6    0                 (ENTRY.) 
          RJ     0                 (*+1)
          BSSZ   1
          BSS    0
 ENTRLN   EQU    *-ENTRCN 
          MOVEND
          SPACE  2
 ENAME    EQU    SCRATCH
 PENTR.   SB4    B4-B6             SKIP TO FIRST CH 
          SB2    B6                BIT COUNT FOR REF
          GCH    X1                FIRST CH FOR REF 
          SB3    X1                FIRST CH FOR REF 
          RJ     REF
          BX6    X3 
          SA6    ENAME             SAVE ADDRESS OF NAME.
          SA1    TEMPA0.
          ZR     X1,PENTR8         IF NO ARGUMENTS
  
*         ENTR. WITH ARGUMENTS
* 
          SA1    TEXT.ADD 
          SA1    X1-3 
          MX0    60-18
          BX1    -X0*X1            GET ORGC 
          SB7    X1 
          MX0    18 
          SA1    ENTRCP+1          GET SECOND WORD
          SX6    B7+6 
          LX0    48                FORM MASK FOR CLEARING UPPER ADDRESSE
          LX6    30 
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          BX6    X6+X1             OR IN ORGC + 6 
          SA6    A1 
          SA1    ENTRCP+5          GET SIXTH WORD 
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          SX6    B7+7 
          SA2    ENTRY. 
          LX6    30 
          BX6    X6+X1             OR IN ORGC + 7 
          SA6    A1 
          SA1    ENTRCP+4          GET FIFTH WORD 
          SX3    X2+B5
          BX1    -X0*X1            CLEAR UPPER
          LX3    30 
          BX6    X1+X3             OR IN ENTRY + 1
          SA6    A1 
          SA5    ENTRCP+7          GET EIGHTH WORD
          SA3    FTNNOP.
          MX6    60-18             FORM MASK FOR CLEARING LOWER ADDRESSE
          BX5    X6*X5             CLEAR LOWER ADDRESS
          BX7    X5+X3             OR IN FTNNOP.
          SA7    A5 
          LX3    30 
          SA1    ENTRCP+2          GET THIRD WORD 
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          BX1    X6*X1             CLEAR LOWER ADDRESS
          BX7    X1+X3             OR IN FTNNOP.
          SX1    B7+4 
          BX7    X7+X1             OR IN ORGC + 4 
          SA7    A1 
          SA1    ENTRCP+6          GET SEVENTH WORD 
          SA3    NOPS.
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          LX3    30 
          SA5    ENAME
          BX1    X6*X1             CLEAR LOWER ADDRESS
          BX7    X1+X3             OR IN NOPS.
          BX7    X7+X5             OR IN NAME.
          SA7    A1 
          SA1    ENTRCP+8          GET NINTH WORD 
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          LX2    30 
          BX7    X1+X2             OR IN ENTR.
          MX0    60-18             FORM MASK FOR CLEARING LOWER ADDRESS 
          SX6    B7+10
          BX1    X0*X7             CLEAR LOWER ADDRESS
          BX7    X6+X1             OR IN ORGC + 10
          MX6    0
          SA7    A1 
          SA6    RBTEMP            PROHIBIT THE PRINTING OF CODE. 
 PENTR7   SA4    ENTRCP            FIRST WORD FOR WRSEQ 
          SA3    ENTRRP 
          SX6    ENTRLP            BLOCK LENGTH FOR WRSEQ 
          BX7    X3                RELOCATION WORD FOR WRSEQ
          RJ     WRSEQ
          EQ     INITL
* 
*         ENTR. WITH NO ARGUMENTS 
* 
 PENTR8   SA2    ENAME
          SA1    ENTRCN+1          GET SECOND WORD
          LX2    30 
          MX0    18 
          LX0    48                FORM MASK FOR CLEARING UPPER ADDRESSE
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          BX6    X1+X2             OR IN NAME 
          SA6    A1 
          SA1    A1+B5             GET THIRD WORD 
          SA3    ENTRY. 
          LX3    30 
          BX1    -X0*X1            CLEAR UPPER ADDRESS
          MX7    0
          BX6    X1+X3             OR IN ENTRY. 
          SA4    TEXT.ADD 
          SA4    X4-3 
          MX3    60-18             FORM MASK FOR CLEARING LOWER ADDRESS 
          BX4    -X3*X4            GET ORGC 
          BX6    X3*X6             CLEAR LOWER ADDRESS
          SX4    X4+4 
          BX6    X4+X6             OR IN ORGC+3 
          SA6    A1 
          SA7    RBTEMP 
  
 PENTR9   SA4    ENTRCN            FIRST WORD FOR WRSEQ 
          SA3    ENTRRN 
          SX6    ENTRLN            BLOCK LENGTH FOR WRSEQ 
          BX7    X3                RELOCATION WORD FOR WRSEQ
          RJ     WRSEQ
          EQ     INITL
          TITLE              SUBROUTINES
************************************************************************
*                                                                      *
* EVAL-   EVALUATE A GENERAL ADDRESS EXPRESSION                        *
*                                                                      *
*         ON ENTRY-                                                    *
*                   A5,B7,B6,B5,B4,X5,X0 ARE SET FOR CHARACTER PICK UP *
*                   X1= THE FIRST N CHARACTERS OF A SYMBOL OR THE      *
*                       FIRST CHARACTER OF A CONSTANT,                 *
*                   X6= NEGFLAG(+OR- ZERO)                             *
*                   X7= PERVIOUS ADDRESS SUM                           *
*                   B2= N*6                                            *
*                   B3= FIRST CHARACTER                                *
*                                                                      *
*         ON EXIT-                                                     *
*                   X4= THE VALUE OF X4 ON ENTRY + THE VALUE OF THE    *
*                       ADDRESS EXPRESSION                             *
*                                                                      *
************************************************************************
          SPACE  2
 NEGFLAG  EQU    SCRATCH+4         2WORDS TO SAVE NEGFLAG AND ADD.SUM 
          SPACE  2
          MOVSTART  11
 EVAL     BSS    1
 EV.1     SA2    =77600000000B
          SA6    NEGFLAG
          SA7    A6+B5             SAVE ADD.SUM AND NEGFLAG 
          LX2    X2,B3
          PL     X2,EV.4           IF SYMBOL THEN CALL REF ELSE CONVERT 
          SX3    X1-1R0            CONSTANT TO BINARY 
          SB2    -1R0 
 EV.2     GCH    X1 
          SX1    X1+B2
          CWD 
          NG     X1,EV.3
          LX3    3
          BX3    X1+X3
          EQ     EV.2 
 EV.3     GCH    X2 
          SB1    X2 
          CWD 
          EQ     EV.5 
          MOVEND
          SPACE  2
          MOVSTART  7 
 EV.4     RJ     REF
          SPACE  2
 EV.5     SA2    NEGFLAG           XOR THE VALUE WITH NEGFLAG AND ADD IT
          SA1    A2+B5             ADD.SUM THEN CHECK THE NEXT CHARACTER
          BX3    X3-X2
          SA2    B1+L3.JVEC 
          IX7    X1+X3
          GCH    X1 
          AX2    24 
          CWD 
          SB2    B6 
          BX2    -X0*X2 
          SB3    X1 
          SB1    X2 
          JP     B1+EV.6
          MOVEND
          SPACE  2
          MOVSTART  3 
 EV.6     MX1    42                SPACE OR ZERO BYTE -- RETURN 
          EQ     EV.7 
 +        BX6    X6-X6             PLUS -- NEGFLAG OFF, GET ANOTHER VALU
          EQ     EV.1 
 +        BX6    -X6+X6            MINUS -- NEGFLAG ON, GET ANOTHER VALU
          EQ     EV.1 
          MOVEND
          SPACE  2
          MOVSTART  1 
 EV.7     BX7    -X1*X7 
          IX4    X4+X7
          EQ     EVAL 
          MOVEND
          EJECT 
************************************************************************
*                                                                      *
* REF-    SUBROUTINE TO REFERENCE THE SYMBOL TABLE AND THE GL,AP AND   *
*         VD TABLES AND RETURN AN ADDRESS VALUE FOR A SYMBOL OR LABEL. *
*                                                                      *
*         CALLING SEQUENCE-                                            *
*                   X1= FIRST N CHARACTERS OF THE NAME (N\1),          *
*                   B2= N*6(BIT COUNT OF THE CHARACTERS IN X1).        *
*                   B3= FIRST CHARACTER OF THE NAME,                   *
*                   B5= 1.                                             *
*                   RJ        REF                                      *
*                                                                      *
*         ON RETURN-                                                   *
*                   X1= WORD A OF SYMTAB ENTRY                         *
*                   X2= WORD B OF SYMTAB ENTRY,                        *
*                   X3= RA FIELD (ADDRESS),                            *
*                   B1= THE DELIMITING CHARACTER FOR THE SYMBOL        *
*                   B5= 1.                                             *
*                                                                      *
*         ALSO-     A5,X5,X4,X0,B7,B6 ARE RESTORED                     *
*                                                                      *
*         THIS ROUTINE MAY CALL PACKID, SYMBOL OR LABEL.               *
*                                                                      *
************************************************************************
          SPACE  2
          EXT    SYMBOL,LABEL 
  
          USE    /TABLES/ 
 A5TEMP   BSS    4
 RBTEMP   BSS    1
          USE    *
  
 REF.X    BX6    X2                EXT SYMBOL 
          IX3    X3-X3             X3 = ADDRESS = 0 
          SA6    RBTEMP 
  
          SPACE  2
 REF      BSS    1
          SB3    B3-1R# 
          NG     B3,R.STAN         IF FIRST CHAR IS ALPHABETIC,. OR ) TH
          SA3    =77600000000B
          SB4    B4-12       SKIP PAST GL/AP/IO 
          MX1    0
          PL     B4,R.SP1 
          SA5    A5+1 
          SB4    B4+60
 R.SP1    GCH    X2          CONVERT THE ORD IN THE SYMBOL TO BINARY
          SB1    X2 
          CWD 
          LX7    X3,B1
          PL     X7,R.SP2 
          SX2    X2-1R0 
          LX1    3
          BX1    X1+X2
          EQ     R.SP1
  
 R.SP2    SA3    B3+=XO.GLT 
          IX1    X1+X3
          SA2    X1-1 
          GT     B3,B5,R.EXIT      IF IO
          SA3    GLAPR
          LX2    P.RA 
          IX2    X2+X3       RELOCATE IN CODE.
          EQ     R.EXIT 
  
          MOVSTART 5
 R.STAN   SA0    B3+B6             A0.= B3+6
          RJ     PACKID            SEPARATE THE SYMBOL
          SX7    A5 
          SX6    B4 
          SA7    A5TEMP 
          SB2    A0 
          SA6    A7+B5
          BX7    X4 
          SX6    B1 
          SA7    A6+B5
          SB7    R.ST1-1
          SA6    A7+B5             SAVE A5,B4,X4,B1 
          PL     B2,LABEL 
          EQ     SYMBOL 
          MOVEND
          SPACE  2
          MOVSTART  9 
 +        EQ     CHKEXT            SEE IF IT IS IN EXTERNAL TABLE 
 R.ST1    SA4    A5TEMP 
          MX0    54 
          SA3    A4+B5
          SA5    X4 
          MX7    60-L.RL
          SB4    X3 
          SA4    A3+B5
          SB6    6
          SB2    P.RL 
          SA3    A4+B5
          AX6    X2,B2
          SB7    54 
          BX6    -X7*X6 
          SB1    X3                RESTORE A5,X5,X4,B7,B6,B4,B1 
          SB2    X6-2 
          NG     B2,R.EXIT         IF ABS OR PROGRAM
          EQ     B2,B5,REF.X       IF EXTERNAL
          SX7    1S"P.RB" 
          IX2    X2-X7             DECREMENT RB CODE BY 1 
          EQ     R.EXIT 
          MOVEND
          SPACE  2
          MOVSTART  6 
 CHKEXT   MX6    L.NAME 
          BX0    X6*X1             NAME 
          SA2    O.EXT
          SA3    L.EXT
          SB1    X2 
          SB2    B1+X3
          SB5    1
  
 CHKL     SA2    B1 
          EQ     B1,B2,SILL        IF NOT FOUND 
          BX3    X6*X2
          SB1    B1+B5
          IX4    X0-X3
          NZ     X4,CHKL           IF NO HIT
  
          SA2    X2                WORD B OF SYMTAB ENTRY 
          EQ     R.ST1
          MOVEND
  
          MOVSTART  4 
 R.EXIT   SA3    RBTEMP 
          SB2    P.RA 
          BX7    X7-X7
          NZ     X3,R.EX1          IF RBTEMP IS ZERO THEN SAVE WORD B EL
          BX7    X2                SET IT TO ZERO.
 R.EX1    AX3    X2,B2
          SA7    A3 
          SX3    X3                X3.= RELATIVE ADDRESS
          EQ     REF
          MOVEND
          SPACE  2
          SPACE  6
************************************************************************
*                                                                      *
*         CONVERT - CONVERT DISPLAY CODED OCTAL TO BINARY              *
*                                                                      *
*                   FIRST CHARACTER MUST BE A NUMBER OR -              *
*                   LAST CHARACTER MUST BE A B                         *
*                                                                      *
*                   CALLING SEQUENCE -                                 *
*                             X3 = FIRST CHARACTER                     *
*                                                                      *
*                   ON EXIT -                                          *
*                             X1 = CONVERTED CONSTANT                  *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  13B 
 CONVERT  BSS    1
          MX0    54 
          BX1    X1-X1
          SX2    1R9
          IX7    X2-X3
          AX7    59 
          SA2    =50000000000000060000B 
          PL     X7,CONVERT2
          GCH    X3 
          SX3    X3-1R0 
          CWD 
 CONVERT1 LX1    3
          BX1    X1+X3
          AX3    X5,B4
          SB4    B4-B6
          CWD 
 CONVERT2 BX3    -X0*X3 
          SB1    X3 
          SX3    X3-1R0 
          LX4    B1,X2
          PL     X4,CONVERT1       IF NOT A B, BLANK OR , 
  
          BX1    X1-X7
          EQ     CONVERT
          MOVEND
          SPACE  4
*********************************************************************** 
*                                                                     * 
*         PACK IDENTIFIER S.R.                                        * 
*         ENTER WITH                                                  * 
*         X1=CHARS ALREADY PACKED                                     * 
*         B2=BIT COUNT OF CHARS ALREADY PACKED                        * 
*                                                                     * 
*         EXITS WITH                                                  * 
*         X1=ID PACKED LEFT JUSTIFIED IN BITS 47-0 WITH BLANK FILL    * 
*         TERMINATING CH IN B1                                         *
*                                                                     * 
*********************************************************************** 
          SPACE  2
          MOVSTART  9 
 PACKID   BSS    1
          SA2    =40000000000032060000B  DELIMITER FLAG WORD (ZRO BYTE
 PK1      GCH    X6                +,-,/,BLANK,COMMA)            PK1
          SB1    X6 
          CWD 
          LX3    X2,B1
          NG     X3,PK2 
          LX1    6
          SB2    B2+B6
          BX1    X1+X6
          EQ     PK1
 PK2      SA2    =8R
          SB3    B2-48
          AX1    X1,B3
          AX2    X2,B2
          BX1    X1+X2
          EQ     PACKID 
          MOVEND
 RCARD    SPACE  4,8
**        RCARD - READ *COMPS* LINE AND SET UP REGISTERS. 
* 
*         ENTRY  NO REQUIREMENTS. 
* 
*         EXIT   NEW LINE IN BUFFER BEGINNING AT (ILINE). 
*                (SWC) = LINE LENGTH (WORDS)
*                (X0) = 54D-BIT MASK, LEFT ADJ
*                (X5) = 2ND WORD OF LINE
*                (X7) = LINE LENGTH (WORDS) 
*                (A5) = ILINE+1 
*                (B1) = 1 
*                (B4) = 54D 
*                (B5) = 1 
*                (B6) = 6 
*                (B7) = 54D 
*                IF PREMATURE EOS/EOP/EOI ON -COMPS, EXITS TO *NOEND*.
* 
*         USES   X - 0, 5, 7
*                A - 5, 7 
*                B - 1, 4, 5, 6, 7
* 
*         CALLS  READC
  
  
 RCARD    ENTRY. *           ** ENTRY/EXIT ** 
          SB1    1
          READC  F.CMPS,ILINE,LINESIZE-ISHIFT 
          NZ     X1,NOEND    IF -COMPS- PREMATURELY EMPTY, ERROR
          SA5    ILINE+1     (X5) = 2ND WORD OF LINE
          SX7    B6-ILINE    (X7) = LINE LENGTH (WORDS) 
          MX0    -6 
          SB5    B1 
          SB4    54D
          SA7    SWC
          SB6    6
          SB7    B4 
          EQ     RCARD       EXIT 
 RTB      SPACE  4,8
**        RTB - REMOVE TRAILING BLANKS. 
* 
*         REMOVES BLANK FILL FROM 7-CHARACTER LEFT-JUSTIFIED VARIABLE 
*         NAME.  PRESERVES LOWER 18 BITS. 
* 
*         ENTRY  (X6) = 42/7H(NAME), 18/(ELSE)
* 
*         EXIT   (X6) = 42/7L(NAME), 18/(ELSE)
* 
*         USES   X4, X7, A4, B7 
  
  
 RTB      ENTRY. *           ** ENTRY/EXIT ** 
          SA4    =1H
          LX6    -18         RIGHT JUSTIFY BLANKS 
          BX7    X6-X4       CONVERT BLANKS TO ZERO BYTES 
          MX4    -1 
          NO
          IX4    X7+X4       BORROW RIPPLES LEFT TO FIRST NON-ZERO BYTE 
          BX7    -X7*X4      BYTES =00 ON LEFT OF BORROW, =77 ON RIGHT
          SA4    =40404040404040404040B 
          SB7    60-5 
          BX4    X4*X7       EACH BORROW BYTE = 40
          LX7    X4,B7                        = 01
          IX7    X4-X7                        = 37
          BX4    X4+X7                        = 77
          BX6    -X4*X6      REMOVE BLANKS
          LX6    18          RESTORE ORIGINAL POSITION
          EQ     RTB         EXIT 
  
 MR.CLEAN =      RTB         LINK OBSOLETE NAME TO ENTRY POINT
 SKIP2    SPACE  4,8
**        SKIP2 - SKIP TWO LINES IN OUTPUT LISTING. 
* 
*         ENTRY  NO REQUIREMENTS. 
* 
*         EXIT   TWO LINES SKIPPED IF BINARY LIST OPTION ON (O = .NZ.)
*                (B1) = 1 
*                (B5) = 1 
* 
*         USES   X1, A1, B1, B5 
* 
*         CALLS  LISTL (FA=LOL) 
  
  
 SKIP2    ENTRY. *           ** ENTRY/EXIT ** 
          SA1    OLIST
          SB1    1
          SB5    B1+
          ZR     X1,SKIP2    IF BINARY LIST OPTION OFF (O = .ZR.), EXIT 
          LISTL  (=2C  ),1
          LISTL  (=2C  ),1
          SB5    B1+
          EQ     SKIP2       EXIT 
 WEOR     SPACE  4,8
**        WEOR - WRITE EOR/EOS ON BINARY OUTPUT FILE. 
* 
*         ENTRY  NO REQUIREMENTS. 
* 
*         EXIT   END-OF-RECORD/SECTION WRITTEN. 
*                (B1) = 1 
*                (B5) = 1 
* 
*         USES   X2, A2, B1, B5 
* 
*         CALLS WRITER
  
  
 WEOR     ENTRY. *           ** ENTRY/EXIT ** 
          SA2    FV.LGO 
          SB1    1
          ZR     X2,WEOR     IF BINARY OUTPUT OPTION OFF (B=0)
          WRITER =XF.LGO,RCL
          SB5    B1+
          EQ     WEOR        EXIT 
          SPACE  2
          EJECT 
************************************************************************
*                                                                      *
* WRSEQ - WRITES BLOCK OF UP TO 15 WORDS INTO TEXT TABLE               *
*                                                                      *
*         CALLING SEQUENCE -                                           *
*                   A4 = STARTING ADDRESS                              *
*                   X4 = FIRST WORD                                    *
*                   X6 = WORD COUNT                                    *
*                   X7 = RELOCATION BYTES, LEFT JUSTIFIED              *
*                                                                      *
************************************************************************
          SPACE  2
          SPACE  2
          USE    /TABLES/ 
 WRSEQR   BSS    3                 RELOC BYTES, WORD COUNT, STARTING AD:  
          USE    *
          SPACE  2
          MOVSTART  4 
 WRSEQ    BSS    1
          SA7    WRSEQR            SAVE RELOCATION BYTES
          SB6    WRSEQ1            SET RETURN ADDRESS FOR WRTEXT
          BX6    -X6
          SA6    A7+B5             SAVE NEGATIVE WORD COUNT 
          SB1    60                SET BIT COUNT FOR WRTEXT 
          SX7    A4+B5
          SA7    A6+B5             SAVE STARTING ADDRESS + 1
          EQ     WRTEXT            GO WRITE FIRST WORD
          MOVEND
          SPACE  1
          MOVSTART  7 
 WRSEQ1   BX7    X7-X7             STOP FURTHER PRINTING OF SOURCE IMAGE
          SA7    ILINE
          SX7    B5 
          SA7    SWC
          SB6    WRSEQ2 
 WRSEQ2   MX0    60-4              SET MASK FOR RELOCATION BYTE 
          SA1    WRSEQR            LOAD RELOCATION BYTES
          LX1    4
          BX5    -X0*X1            MASK OFF NEXT RELOCATION BYTE
          IX6    X6+X5             ADD IN RELOCATION BYTE 
          SA6    A3                STORE RELOCATION BYTE
          SA2    A1+B5             LOAD WORD COUNT
          SX6    X2+B5
          ZR     X6,WRSEQ          SENSE LAST WORD MOVED
          SA6    A2 
          SA4    A2+B5             LOAD ADDRESS OF NEXT WORD TO MOVE
          SX7    X4+B5
          LX6    X1 
          SA7    A4 
          SA6    A1 
          SA4    X4                LOAD NEXT WORD TO MOVE 
          EQ     WRTEXT 
          MOVEND
          EJECT 
************************************************************************
*                                                                      *
* WRTEXT - FORMS AND WRITES TEXT TABLES FOR THE LOADER                 *
*                                                                      *
*         CALLING SEQUENCE -                                           *
*                   B6.= RETURN ADDRESS                                *
*                   B5.= 1                                             *
*                   X4.= INSTRUCTION OR DATA TO BE OUTPUT              *
*                   B1.= BIT COUNT OF INSTRUCTION OR DATA              *
*                   EQ  WRTEXT                                         *
*                                                                      *
*         ON EXIT -                                                    *
*                   X6 = ADJUSTED RELOCATION BYTE WORD                 *
*                   A3 = ADD. OF THE RB WORD                           *
*                   B7 = TEXT ADDRESS                                  *
*                   B5 = 1                                             *
*                                                                      *
*         THIS ROUTINE WILL CALL WRWDS TO WRITE A FULL TEXT TABLE AND  *
*         WRLIST IF THE SWITCH AT WRTSW HAS BEEN SET.                  *
*                                                                      *
************************************************************************
          SPACE  2
          USE    /TABLES/ 
 OCTEMP   BSS    3
          USE    *
 BCTEMP   EQU    OCTEMP+1 
 RETEMP   EQU    OCTEMP+2 
          SPACE  2
 L4.15    SB6    INITL             ENTER WITH A 15 BIT QUANTITY 
          SB1    15 
          SPACE  2
 WRTEXT   SA2    TEXT.ADD          ADDRESS OF CURRENT TEXT TABLE
          SA1    FFLAG
          SB7    X2                B7.=TEXT.ADD 
          SA2    B7-B5             X2.= TABC
          SA3    A2-B5             X3.= POSC
          SB2    X2 
          SA5    B2+B7             X5.=CURRENT WORD(CW) 
          SB3    X3 
          SX1    X1-1 
          SB4    B3-60
          NG     X1,WRT5           IF FFLAG GTR 0 AND POSC NEQ 60 THEN F
          ZR     B4,WRT5           UPPER. 
 WRT1     SA1    A3-B5             X1.= ORGC
          SA3    B7+B5             X3.= RELOCATION BYTE WORD
          SX0    46000B            X0.= NO-OP 
 WRT2     ZR     B3,WRT3           IF POSC=0 THEN EXIT ELSE SHIFT NO-OP 
          SB3    B3-15             POSC AND .OR. TO CW, POSITION RELO WO
          LX2    X0,B3
          IX3    X3+X3
          BX5    X5+X2
          EQ     WRT2 
  
 WRT3     SX7    B5 
          IX7    X1+X7
          BX6    X5 
          SA7    A1                ORGC.= ORGC+1
          SB2    B2+B5             TABC.=TABC+1 
          LX7    X3,B0
          SB4    B2-17
          SA6    A5                STORE CW 
          SA7    A3                SAVE RELO BYTE WORD
          NZ     B4,WRT4           IF TABC=17 THEN WRITE THIS TABLE AND 
          BX6    X4                A NEW ONE. 
          SA1    B7 
          SX7    B2-B5
          LX7    36 
          SA6    OCTEMP            SAVE CURRENT INSTRUCTION 
          BX7    X1+X7
          SA7    A1                WORD COUNT.=TABC-1 
          SX6    B1 
          SX7    B6 
          SA6    A6+B5             SAVE BIT COUNT 
          SA7    A6+B5             SAVE RET. ADD. 
* IF SNAPTEXT=1 THEN DUMP THE FULL TEXT TABLE.
 SNAPTEXT EQU    DEBUG
          IFEQ   SNAPTEXT,1,1 
 TXT-TBWR SNAP   *TEXT.ADD,,17,NR 
  
          SA4    FV.LGO 
          SB1    1
          ZR     X4,WRT3A          IF B = 0 
          SB6    B7 
          WRITEW F.LGO,B6,B2
 WRT3A    SA5    TEXT.ADD          X5=. TEXT TABLE ADDRESS
          MX2    1                 X2.=TEXT HEADING 
          SB5    B1 
          SA1    X5-3              X1.= ORGC
          BX6    X1+X2
          SB7    X5 
          SA6    X5                STORE NEW ID WORD
          SX7    B0 
          SA7    A6+B5             CLEAR RB WORD
          SA4    OCTEMP            RESTORE OPCODE, BIT COUNT AND RET ADD
          SB2    B5+B5             TC.= 2 
          SA3    A4+B5
          SA1    A3+B5
          NO
          SB1    X3 
          SB6    X1 
 WRT4     BX5    X5-X5             CW.= 0 
          SB3    60                POSC.= 60
 WRT5     SB4    B3-B1             POSC.= POSC-BIT COUNT
          NG     B4,WRT1           IF POSC LSS 0 THEN FORCE UPPER 
          SX7    B2 
          LX3    X4,B4
          SA7    B7-B5             SAVE      TABC 
          BX6    X3+X5
          SX7    B4 
 WRTSW    SA6    B7+B2             PACK NEW BINARY INTO CW AND STORE
          SA7    A7-B5
          NO     0                 THESE TWO NO-OPS ARE REPLACED BY AN R
          NO     0                 WRLIST WHEN THE -O- OPTION IS SPECIFI
          SX1    B1+4 
          SA3    B7+B5
          AX1    4
          SB2    X1 
          LX6    X3,B2             SHIFT THE RELO BYTE WORD BY ONE BIT F
          SA6    A3 
          JP     B6                EACH 15 PACKED AND LEAVE IT IN X6
          SPACE  4
**********************************************************************
*                                                                    *
* FOTEXT- FORCE OUT THE (PARTIALLY FILLED) TEXT TABLE THAT IS INDI-  *
*         CATED BY TEXT.ADD.                                         *
*                                                                    *
*         CALLING SEQUENCE-                                          *
*                   RJ FOTEXT                                        *
*                                                                    *
*         ON RETURN-                                                 *
*                   THE CUREENT TEXT TABLE HAS BEEN WRITTEN ON LGO   *
*                   WITH THE RELOCATION BYTE WORD ADJUSTED AND THE   *
*                   CORRECT WORD COUNT -IF IT IS NOT EMPTY. THE NEW  *
*                   TABLE IS PROPERLY INITALIZED.                    *
*                                                                    *
**********************************************************************
          SPACE  2
 FOTEXT   ENTRY. *                 ** ENTRY/EXIT ** 
          SX6    B5 
          SB6    FOTEXT2           RETURN ADDRESS FOR WRTEXT
          BX4    X4-X4             CLEAR DATA 
          SB1    B0                BIT COUNT FOR WRTEXT 
          SA6    FFLAG             SET FORCE FLAG 
          EQ     WRTEXT            GO FORCE UPPER 
  
 FOTEXT2  SA2    B7-B5             GET TABC 
          SX7    B5+B5
          SB6    B7 
          IX6    X2-X7
          ZR     X6,FOTEXT1        SENSE EMPTY TEXT TABLE 
          SA3    B7                GET ID WORD
          SX6    X6+B5             FORM WORD COUNT FOR TEXT TABLE 
          LX6    36 
          BX6    X6+X3             OR IN WORD COUNT 
          SA7    A2                RESET TABC TO 2
          SA6    B7 
          SX0    17 
          IX0    X0-X2
          LX0    2
          SA4    B7+B5             GET RELOCATION BYTE
          SB3    X0 
          LX6    X4,B3             ADJUST LEFT BY 4*(17-TABC) 
          SA6    A4 
* IF SNAPTEXT=1 THEN DUMP THIS TABLE. 
          IFEQ   SNAPTEXT,1 
 TXT-TBFO SNAP   *TEXT.ADD,,17,NR 
          ENDIF 
  
          SA4    FV.LGO 
          SB1    1
          ZR     X4,FOTEXT3        IF B = 0 
          SB7    X2 
          WRITEW F.LGO,B6,B7
          SB5    B1+
 FOTEXT3  SA1    TEXT.ADD 
          BX6    X6-X6
          IX7    X7-X7
          SA6    X1+B5             CLEAR RELOCATION BYTE
          SA2    X1-3              GET RB AND ORGC
          SA7    A6+B5             CLEAR THIRD WORD OF TEXT TABLE 
          MX6    1
          BX6    X6+X2
          SA6    X1                RESET ID WORD
          EQ     FOTEXT 
  
 FOTEXT1  SA2    B7-3              GET RB AND ORGC
          MX6    1
          BX6    X6+X2
          SA6    B7                RESET ID WORD
          EQ     FOTEXT 
          EJECT 
************************************************************************
*                                                                      *
* WRLIST- SUBROUTINE TO PROVIDE AN ASSEMBLER LISTING. THE LISTING IS   *
*         OPTIONAL AND IS PROVIDED ON THE -O- OPTION WHEN PASS II OF   *
*         THE COMPILER IS SET TO IGNORE IT.                            *
*         THE LISTING INCLUDES FOR EACH SOURCE LINE -                  *
*                                                                      *
*                   THE VALUE OF THE ORGC AND THE NAME OF THE THE CUR- *
*                   RENT RELOCATION BASE AFTER EACH FORCE UPPER,       *
*                                                                      *
*                   THE BINARY GENERATED, IF ANY, BY THE LINE,         *
*                                                                      *
*                   THE NAME OF THE RELOCATION BASE THAT THE ADDRESS   *
*                   FIELD REFERS TO, IF AN ADDRESS IS PRESENT AND IF   *
*                   IT IS NOT ABSOLUTE OR EXTERNAL.                    *
*                                                                      *
*                   THE ORIGINAL SOURCE LINE.                          *
*                                                                      *
*         ON ENTRY  X4 = BINARY                                        *
*                   B6 = 0 IF THERE IS NO BINARY IN X4                 *
*                   B5 = 1                                             *
*                   B3 = OLD POSC                                      *
*                   B1 = BIT COUNT OF THE BINARY, 0 IF IT IS NOT TO BE *
*                        PRINTED.                                      *
*                                                                      *
*         ON EXIT B7,B6,B5, AND B1 ARE RESTORED.                       *
*                                                                      *
*         THIS ROUTINE CALLS LIST  TO PRINT THE LINE AND CLINE TO      *
*         CLEAR THE PRINT BUFFER                                       *
*                                                                      *
************************************************************************
          USE    /TABLES/ 
 B6T      BSS    2
 BSPFLAG  BSS    1
          USE    *
          SPACE  2
 WRLIST   ENTRY. *                 ** ENTRY/EXIT ** 
          ZR     B1,WRLIST         IF BIT COUNT=0 THEN RETURN.
          SX7    B6 
          SX6    B1 
          SA7    B6T               SAVE B1 AND B6 
          SA6    A7+1 
          SB7    B3 
          ZR     B6,WRL.6          IF B6=0 THEN THERE IS NO BINARY, PRIN
          SB6    B1                THE LINE AND RETURN ELSE CONVERT THE 
          MX1    0                 BINARY TO DISPLAY. 
          SA2    =10H0000000000 
          SX0    7
          SB4    10 
 WRL.1    SB6    B6-3              CONVERT THE OCTAL IN X4 TO 6 BIT CODE
          AX3    X4,B6
          BX3    X0*X3
          LX1    6
          BX1    X1+X3
          SB4    B4-1 
          ZR     B6,WRL.2 
          NZ     B4,WRL.1          IF BC=60 THEN STORE FIRST WORD IN LIN
          IX6    X1+X2             AND REINITIALIZE TO PACK THE SECOND. 
          SB1    B1-30
          MX1    0
          SA6    LINE+2 
          SB3    B3-30
          SB4    10 
          EQ     WRL.1
          SPACE  2
 WRL.2    SX5    B3 
          SB6    B1-30
          AX5    5
          ZR        B6,WRL.3  IF BC=30 THEN ZERO FILL, STORE, CHECK 
          SX3       B3        RBTEMP ELSE BLANK FILL, DETERMINE 
          SA2       =10H     00000  HALF WORD POSITION AND STORE. 
          LX3    59 
          IX6    X1+X2
          NG     X3,WRL.5 
          LX6    30 
          EQ     WRL.5
          SPACE  2
 WRL.3    SB6    B7-45             IF POSC=45 THEN SPLIT THE 30 BIT QUAN
          NZ     B6,WRL.4          BETWEEN 2 WORDS. 
          LX1    30 
          SA2    =10H00000
          MX0    30 
          BX6    X0*X1
          IX6    X6+X2
          SA6    LINE+3 
          LX2    30 
          BX1    -X0*X1 
          SPACE  2
 WRL.4    SA3    RBTEMP            PRINT THE RELOCATION OF THE ADDRESS F
          MX7    60-L.RL     IF IT IS NOT ABSOLUTE. 
          LX3    -P.RL
          BX7    -X7*X3 
          IX6    X1+X2
          SB4    X7 
          LX3    P.RL-P.RB
          JP     B4+WRL.41         JUMP INTO WRL.41 USING THE RL FIELD
  
 WRL.41   EQ     WRL.5             ABSOLUTE, EXIT 
 +        SA1    LORGTAB           PROGRAM RELOCATION 
          EQ     WRL.42 
 +        SA1    CORGTAB           COMMON RELOCATION
          EQ     WRL.42 
+         SA1       =10H <EXT>
          BX7    X1 
          SA7    LINE+ISHIFT-1
          EQ     WRL.5
          SPACE  2
 WRL.42   SA2    =20000000000000000026B 
          MX0    60-L.RB
          SB4    X1                PRINT IT.
          BX3    -X0*X3 
          PX3    X3,B0
          SA4    =3R
          DX3    X3*X2
          MX0    42 
          SA1    B4+X3
          BX1    X0*X1
          BX7    X1+X4
          LX7    54 
          SA7    LINE+ISHIFT-1
          SPACE  2
 WRL.5    LX5    59 
          AX5    58 
          SA6    X5+LINE+3
          SPACE  2
 WRL.6    SB4    B7-60             IF POSC=60 THEN PRINT ORGC AND BLOCK 
          NZ     B4,WRL.8 
          SB6    15 
          SA4    TEXT.ADD 
          SA2    BSPFLAG
          MX0    57 
          BX6    X6-X6
          SA1       =10H   000000 
          SA3    X4-3              X3.= ORGC
          SA5    =3R
          IX3    X3-X2
          SA6    A2 
 WRL.7    AX2    X3,B6
          BX2    -X0*X2 
          SB6    B6-3 
          BX6    X2+X6
          LX6    6
          PL     B6,WRL.7 
          IX6    X6+X1
          SA3    X4-5 
          MX0    42 
          BX7    X0*X3
          SA6    LINE              STORE THE CONVERTED ORGC IN LINE 
          BX7    X7+X5
          SA7    A6+B5             STORE THE BLOCK NAME IN LINE+1 
          SPACE  2
 WRL.8    SA1    SWC               WORD COUNT                          W
          SB1    1
          LISTL  LINE,X1+ISHIFT    LIST THE LINE
          SA2    =10H 
          SB5    B1 
          BX6    X2 
          SETCORE   LINE,ISHIFT 
          BX6    X6-X6
          SA6    ILINE             INHIBIT FURTHER PRINTING OF SOURCE IM
          SX7    B5 
          SA7    SWC
          SA1    B6T               RESTORE B1 AND B6
          SA2    A1+B5
          SB6    X1 
          SA3    TEXT.ADD 
          SB1    X2 
          SB7    X3 
          EQ     WRLIST 
 JOL      EJECT 
**        JOL - JUSTIFY OBJECT LISTING
*         FORMATS LOCATION,OP AND ADDRESS FIELDS TO COLUMNS 2, 11 AND 18
  
 OJL      IFNE   .JOL,0 
 RJJOL    RJ     JOL
  
          USE    /TABLES/ 
          BSS    1                 FILLER USED FOR ADDR ASSIGNMENT
 ILINEB   BSS    10B               TEMPORARY BUFFER 
          USE    *
  
 JOL0     SA1    SWC
          SB1    1
 JOL      ROUTINE 
          SA1    SWC               MOVE OBJ LISTING WORDS TO TEMP BUFFER
          SA6    ILINEB-1 
          SA2    ILINE-1
          SA0    A2+B5
          SB2    -B5
 JOL1     SA2    A2+B5
          SX1    X1+B2
          BX6    X2 
          SA6    A6+B5
          NZ     X1,JOL1           IF MORE WORDS
  
          SA5    ILINEB 
          SB4    54 
          MX0    -6 
          AX1    B4,X5             GET AND TEST FIRST CHARACTER 
          SB4    B4-6 
          BX6    -X0*X1 
          MX7    0
          ZR     X6,JOL0           IF NO OBJECT LISTING 
          SX4    X6-1R* 
          ZR     X4,JOL0           IF COMMENT 
          SX2    10 
          SX4    X6-1R+ 
          ZR     X4,JOL2           IF FIRST COLUMN IS + 
          SX4    X6-1R- 
          ZR     X4,JOL2           IF FIRST COLUMN IS - 
          SX2    X2-1 
          SX7    1R 
 JOL2     LX7    6
          SX2    X2-1 
          IX7    X7+X6             SET LOCATION FIELD 
          AX1    B4,X5
          SB4    B4-6 
          BX6    -X0*X1 
          SX4    X6-1R
          NZ     X4,JOL2           IF NON-BLANK 
  
          SX3    6
          IX1    X3*X2
          SB6    X1 
          LX7    B6,X7
          SA1    SPACES+X2
          BX7    X7+X1             PAD WITH BLANKS
          SA7    A0 
          SB6    X3 
          SB1    -1R
          SB3    54 
          SA0    B5 
          SB4    B4+B6
          MX7    0
 JOL3     SB4    B4-B6             FIND OP CODE 
          AX1    B4,X5
          BX4    -X0*X1 
          SX3    X4+B1
          ZR     X3,JOL3           IF BLANK 
          SX3    B6+B5
 JOL4     PL     B4,JOL4A          IF WORD NOT EXHAUSTED
          SA5    A5+B5
          SB4    B3 
 JOL4A    AX1    B4,X5
          SB4    B4-B6
          BX4    -X0*X1 
          SX6    X4+B1
          IX7    X7+X4
          SX3    X3-1 
          LX7    6
          NZ     X6,JOL4           IF NOT BLANK 
          SA4    SPACES+X3
          SX6    B6 
          SX3    X3+B2
          IX1    X3*X6
          SB2    X1 
          LX7    B2,X7
          SB2    3
          BX7    X7+X4             PAD WITH BLANKS
 JOL5     PL     B4,JOL5A          IF WORD NOT EXHAUSTED
          SA5    A5+B5
          SB4    B3 
 JOL5A    AX1    B4,X5
          SB4    B4-B6
          BX6    -X0*X1 
          SX4    X6+B1
          ZR     X4,JOL5           IF BLANK 
          LX7    6
          SB2    B2-B5
          IX7    X6+X7             SET OPERAND FIELD
          ZR     X6,JOL6           IF LINE FINISHED 
          NZ     B2,JOL5           IF WORD FILLED 
          SA7    A7+1 
          SB2    10 
          SA0    A0+B5
          MX7    0
          EQ     JOL5 
  
 JOL6     SX4    B2 
          SX5    B6 
          IX5    X4*X5
          SB4    X5 
          LX7    B4,X7             SHIFT LAST WORD INTO PRINT POSITION
          SA7    A7+1 
          SX6    A0+B5
          NZ     B4,JOL7     IF 2 BYTE EOL FLAG EXISTS AT END OF WORD 
          MX7    0
          SX6    X6+B5
          SA7    A7+B5
 JOL7     SA6    SWC
          EQ     JOL0 
  
 OLJ      ENDIF 
          EJECT 
************************************************************************
*                                                                      *
* L4.CKL- ENTER HERE AFTER A 60 BIT PSEUDO-OP HAS BEEN WRITTEN TO      *
*         DEFINE ITS LABEL IF PRESENT.                                 *
*                                                                      *
*         ON ENTRY-                                                    *
*                   B5= 1,                                             *
*                   ALABEL= ZERO OR A LABEL,PACKED AS REQUIRED BY      *
*                           LSTPROC                                    *
*                                                                      *
*         ON EXIT-                                                     *
*                   X6,A3,B5 ARE RESTORED,                             *
*                   THE LABEL HAS BEEN DEFINED IN THE TWO WORD SYMBOL  *
*                   TABLE AS HAVING THE CURRENT VALUE OF THE ORIGION   *
*                   COUNTER                                            *
*                                                                      *
************************************************************************
          SPACE  2
          MOVSTART  4 
 L4.CKL   SA1    TEXT.ADD 
          SA3    X1+B5
          BX6    X3 
          SPACE  4
************************************************************************
*                                                                      *
* L4.CKRB ENTER HERE FROM WRTEXT OR L4.CKL AFTER A 30 OR 60 BIT QUAN-  *
*         TITY HAS BEEN WRITTEN TO RECORD THE RELOCATION OF THE ADDRESS*
*         FIELD.                                                       *
*                                                                      *
*         ON ENTRY-                                                    *
*                                                                      *
*                   X6= RELOCATION BYTE WORD FROM THE TEXT TABLE       *
*                   A3= ADDRESS OF THE ABOVE                           *
*                   B5= 1                                              *
*                   RBTEMP= ZERO OR WORD B OF THE TWO WORD SYMBOL      *
*                           TABLE ENTRY                                *
*                                                                      *
*         IF THE ADDRESS FIELD IS-                                     *
*                   ABSOLUTE- NO ACTION IS REQUIRED,                   *
*                   PROGRAM-  ADD 2 TO RB WORD IN X6 AND STORE IT BACK,*
*                   COMMON OR                                          *
*                   EXTERNAL- AN ENTRY MUST BE MADE IN THE PROPER FILL *
*                             OR LINK CHAIN TO DESCRIBE THE USE OF THE *
*                             VARIABLE.                                *
*                             IF THE SYMBOL IS AN EXTERNAL THEN RA     *
*                             POINTS TO THE START OF THE CHAIN.        *
*                             IF COMMON THEN CORGTAB+RB*22 IS THE      *
*                             POINTER.                                 *
*                                                                      *
************************************************************************
          SPACE  2
 L4.CKRB  SA1    RBTEMP 
          ZR     X1,INITL          IF RBTEMP=0 THEN EXIT. 
          LX1    -P.RL
          MX0    60-L.RL
          BX2    -X0*X1 
          SB1    X2                B1.= RL
          JP     B1+L4.CKJT 
          MOVEND
          SPACE  2
          MOVSTART  4 
 L4.CKJT  MX7    0
          SA7    A1          RBTEMP = 0 
          EQ     INITL
 +        SX1    B5+B5             PROGRAM
          BX7    X7-X7
          EQ     L4.PROG
 +        LX1    P.RL-P.RB         COMMON 
          MX0    60-L.RB
          EQ     L4.COM 
 +        LX1    P.RL-P.RA         EXTERNAL 
          SA4    X1                X4.= POINTER TO LINK CHAIN 
          EQ     L4.LAF 
          MOVEND
          SPACE  2
          MOVSTART  3 
 L4.PROG  IX6    X1+X6
          SA7    A1                RBTEMP.= 0 
          SA1    RJTFLAG
          SA6    A3          RBWORD = RBWORD + 2
          ZR     X1,INITL 
          SB1    X1 
          JP     B1 
          MOVEND
          SPACE  2
 L4.COM   BX1    -X0*X1 
          SA2    =20000000000000000026B 
          PX1    X1,B0
          SA3    CORGTAB
          DX1    X1*X2
          SB1    X3 
          SB0    B0+
          SA4    X1+B1             X4.= CORGTAB+22*RB, POINTER TO FILL C
          SPACE  2
 L4.LAF   SA1    TEXT.ADD 
          SA3    FREEMEM           X3.= NEXT FREE WORD ADDRESS
          SA1    X1-2              X1.= POSC
          SA5    MEMEND 
          SX1    X1+104B
          IX5    X5-X3
          AX1    4                 X1.= P.= POSC/15+100B
          SA2    A1-B5             X2.= ORGC
          NG     X5,STOVER         IF FREEMEM GTR MEMEND THEN STORAGE OV
          LX1    27                FLOW 
          SX6    X3+B5
          MX0    42 
          BX1    X1+X2             X1.= DATA BYTE 
          SX7    X4                X7.= OLD POINTER 
          SA6    A3                FREEMEM.= FREEMEM+1
          LX1    30 
          BX4    X0*X4
          IX6    X1+X7
          BX7    X4+X3             X7.= NEW START OF CHAIN
          SA6    X3 
          SA7    A4 
          BX6    X6-X6
          SA1    RJTFLAG
          SA6    RBTEMP      RBTEMP = 0 
          ZR     X1,INITL 
          SB1    X1 
          JP     B1 
          TITLE     ERROR PROCESSING
 ILL      SA1    =10H**ILL**
          BX6    X1 
 ILL.1    SA6    LINE+3 
          SA6    ERRLINE+8
          SB3    60 
          SB1    B5 
          SB6    B0 
          RJ     WRLIST            LIST THE CURRENT LINE
 ILL.2    SB1    1
          LISTL  ERRLINE,10D       NEXT LINE, TO EASE FINDING BAD LINE
          SA1    AERCNT 
          SB5    1
          SX6    X1+B1
          SA6    A1                INCREMENT ASSEMBLY ERROR COUNT 
          EQ     INITL
  
*         STORAGE OVERFLOW
  
 STOVER   SA1    MEMSTRT           ENTER HERE ON STORAGE OVERFLOW,ADD SI
          SA2    MEMEND            OF OVERFLOW TO STOVSIZE, PRINT ERROR 
          BX6    X1                MESSAGE AND CONTINUE.
          SA3    STOVSIZE 
          IX1    X2-X1
          SA6    FREEMEM
          IX7    X3+X1
          SA7    A3 
          NZ     X3,INITL 
          SB1    1
          LISTL  OFLOMSG,4
          EQ     ILL.2
  
  
 OFLOMSG  DATA   38C  ********** MEMORY OVERFLOW IN -FAX-.
          SPACE  2
 SILL     BSS    0
* 
* IF SNAPUDEF=1 THEN PRINT THE REGS TO LOOK AT THE UNDEFINED SYMBOL.
* 
 SNAPUDEF EQU    DEBUG
          IFEQ   SNAPUDEF,1,1 
 X0=SYM   REG 
          SA5       =10HSYMBOL ERR
          BX6    X5 
          EQ     ILL.1
          SPACE  4
          SPACE  2
          SPACE  2
          EJECT 
          TITLE     END PROCESSING
          MOVSTART  2 
 XFERTAB  VFD    6/46B,18/1,36/0
          BSS    1
          MOVEND
 FOFLAG   EQU    SCRATCH           1 WORD 
 B4TMP    EQU    SCRATCH           3 WORDS
 NOEND    SPACE  4,8
 NOENDMSG DATA   31C  OBJECT CODE END LINE MISSING. 
  
  
*         PROCESS ERROR - MISSING END LINE. 
  
 NOEND    MESSAGE  NOENDMSG,,RCL
          SA1    AERCNT 
          SX6    X1+B1       ASSEMBLY ERROR COUNT + 1 
          SA6    A1 
          SPACE  2
 PEND     SA1    AERCNT 
          SB1    1
          ZR     X1,EX.20          IF NO ASSEMBLY ERRORS
          SA2    =XCP.ERCT         UPDATE ERROR COUNT GRAND TOTAL 
          IX6    X1+X2
          SA6    A2 
          CALL   CDD               RETURNS (X6) = INTEGER, DPC FORMAT 
          SA2    PREFIX+1          PROGRAM NAME 
          SA6    AERMSG            STORE BCD ERROR COUNT
          BX7    X2 
          SA7    A6+3 
          MESSAGE  AERMSG,,RCL     ASSEMBLY ERROR MSG TO DAYFILES 
          SA1    FV.LGO 
          SB5    1
          ZR     X1,EX.90          IF NO LGO FILE 
          RJ     WEOR              WRITE AN EOR 
          BKSP   F.LGO
  
*         WRITE A PREFIX TABLE
  
 EX.12    SB1    1
          WRITEW F.LGO,PREFIX,L.PRFX
          WRITEW F.LGO,CERMSG,3 
          SA1    AERCNT 
          SB5    B1+
          NZ     X1,EX.90          IF ASSEMBLY ERRORS 
          EQ     EX.100 
  
          MOVSTART  4 
 AERMSG   DATA   10H
          DIS       ,/ ASSEMBLY ERRORS IN  NAME/
          MOVEND
  
 CERMSG   DATA      26CERRORS IN FTN COMPILATION. 
          SPACE  3
          MOVSTART  7 
 EX.20    SA1    FV.LGO 
          ZR     X1,EX.90          IF NO LGO FILE 
  
*  FORCE OUT ALL PARTIALLY FILLED TEXT TABLES 
* 
          SA1    CORGTAB
          SX6    X1-17
          SA6    TEXT.ADD 
          SA6    FOFLAG 
          SPACE  2
 EX.30    SA1    TEXT.ADD 
          SA2    X1+17
          ZR     X2,EX.31 
          SX6    X1+22
          SA6    A1 
          RJ     FOTEXT 
          EQ     EX.30
          MOVEND
          SPACE  2
          MOVSTART  4 
 EX.31    SA3    FOFLAG 
          SA2    LORGTAB
          ZR     X3,EX.40 
          SX6    X2-17
          BX7    X7-X7
          SA6    A1 
          SA7    A3 
          EQ     EX.30
          MOVEND
          SPACE  2
 EX.40    BSS    0
  
*         INCREASE WORKING STORAGE BY USING ALL MEMORY FROM (FREEMEM) 
*         TO END OF FIELD LENGTH, THIS DISCARDS ALL TABLES UP 
*         THROUGH THE SYMBOL TABLE AND THE REFMAP BUFFER
  
          SA1    =XCP.NFLS
          SA2    FREEMEM
          SB6    X1-2              WORKING STORAGE LWA
          SB7    X2+B5             (B7) = WORKING STORAGE FWA 
          SB1    7777B       MAXIMUM PERMITTED WSA
          SB6    B6-B7       WSA LENGTH AVAILABLE 
          SX7    B7 
          LE     B6,B1,EX.45 IF WSA AVAILABLE .LE. MAX ALLOWABLE
          SB6    B1 
  
 EX.45    SX6    X2+B6
          SA7    A2          UPDATE FREEMEM 
          SA6    MEMEND      SET MAX CORE LIMIT 
  
* FORM THE ACCUMULATED COMMON AND EXTERNAL INFORMATION INTO FILL AND
* LINK TABLES AND WRITE THESE ON LGO. 
* 
          MX0    30 
          SB4    22                INDEX FOR CORGTAB
          SA1    CORGTAB
          SB1    B0                WORD COUNT 
          SX7    42B
          SA5    X1-22
          LX7    54 
          SB2    B0 
          SA7    B7 
          SPACE  2
 EX.50    SA5    A5+B4             FETCH NEXT ENTRY 
          ZR     X5,EX.60          IF ZERO THEN QUIT
          SX7    X5 
          ZR     X7,EX.50          IF CHAIN IS EMPTY THEN TRY THE NEXT. 
          EQ     B4,B5,EX.51       IF LINK THEN GO TO PUT IN NAME ELSE
          SA4    A5+2              PUT IN LCT ORDINAL.
          NG     X4,EX.50          IF LCM COMMON BLOCK
          ZR     B2,EX.52          IF X6 HAS A HALF WORD THEN PUT LCT IN
          SB3    B1+B5             LOWER 30 BITS AND STORE IT IN TABLE. 
          GE     B3,B6,EX.53       IF BUFFER IS FULL THEN GO PUT IT OUT 
          AX4    18                ELSE PUT LCT IN TABLE AND GO FOLLOW T
          SA1    X5                CHAIN. 
          BX6    X6+X4
          SB1    B1+B5
          SB2    X5 
          SA6    B1+B7
          EQ     EX.NO
          SPACE  2
          MOVSTART  2 
 EX.52    AX4    18 
          SX1    X5 
          LX4    30 
          SB3    X5 
          BX6    X4 
          EQ     EX.ONE 
          MOVEND
          SPACE  2
          MOVSTART  2 
 EX.53    SA5    A5-B4
          SB1    B1+B5
          SB2    B0 
          SA6    B1+B7
          EQ     EX.70
          MOVEND
          SPACE  2
 EX.51    MX7    42 
          ZR     B2,EX.54 
          SB3    B1+B5
          BX4    X7*X5
          GE     B3,B6,EX.53       IF BUFFER IS FULL THEN GO WRITE IT OU
          LX4    30 
          SX1    X5 
          BX3    -X0*X4 
          SB1    B1+B5
          BX6    X3+X6
          SB3    X5 
          SA6    B1+B7
          NO
          BX6    X0*X4
          EQ     EX.ONE 
          SPACE  2
 EX.54    SB3    B1+B5
          BX6    X7*X5
          GE     B3,B6,EX.55
          SA1    X5 
          SB1    B1+B5
          SB2    X5 
          SA6    B1+B7
          SPACE  2
 EX.NO    ZR     B2,EX.50          CHAIN FOLLOWER- EXITS TO EX.50 WHEN E
          SB3    X1                OF LIST IS ENCOUNTERED.
          BX6    X0*X1
 EX.ONE   SA1    X1 
          ZR     B3,EX.50 
          BX3    X0*X1
          SB2    X1 
          LX3    30 
          SA1    X1 
          BX6    X3+X6
          SB1    B1+B5
          SA6    B7+B1
          LT     B1,B6,EX.NO
  
 EX.70    RJ     DBB               DUMP BINARY BUFFER 
          SX7    42B               FILL TABLE 
          NE     B4,B5,EX.71       IF PROCESSING FILLS
          SX7    44B               LINK TABLE 
 EX.71    LX7    54 
          SA7    B7                RESET ID WORD IN TABLE 
  
          EQ     B4,B5,EX.72     IF PROCESSING LINKS
          SX5    B2              CHAIN POINTER
          SB2    B0 
          SA4    A5+2            OCT ORDINAL
          EQ     EX.52
* 
EX.72     MX7    42 
          BX6    X7*X5           LINK NAME
          SX5    B2              CHAIN POINTER
          BX5    X6+X5
          EQ     EX.54
          SPACE  2
          MOVSTART  1 
 EX.55    SA5    A5-B4
          EQ     EX.70
          MOVEND
          SPACE  2
 EX.60    ZR     B4,EX.64          IF ALL EXTERNALS DONE
          ZR     B2,EX.61 
          SB1    B1+B5
          SB2    B0 
          SA6    B1+B7
 EX.61    EQ     B4,B5,EX.62
          SA4    LINKTAB
          SB4    B5 
          SA5    X4-1 
          GE     B1,B5,EX.70       IF BUFFER IS NOT EMPTY THEN WRITE IT 
          EQ     EX.63
 EX.62    SB4    B0                EXTERNAL 
          GT     B1,B5,EX.70
 EX.63    SB1    B0 
          SX7    44B
          LX7    54 
          SA7    B7 
          EQ     EX.50
  
* 
*         DUMP BINARY BUFFER TO BINARY FILE 
* 
 DBB
          SA1    B7+B5       FIRST WORD AFTER HEADER
          NZ     X1,DBB.1    IF NORMAL TABLE ENTRY
          SA2    B7 
          SB1    B1-B5       DECREMENT TABLE LENGTH 
          SB7    B7+B5       INCREMENT HEADER ADDRESS 
          BX6    X2 
          SA6    B7          MOVE HEADER WORD DOWN
 DBB.1    SA1    B7 
          SX2    B1 
          SX7    A5 
          SX6    B4 
          LX2    36 
          SB6    B7 
          SA6    B4TMP             SAVE B4,A5,B2
          SB7    B1+B5
          SA7    A6+B5
          BX6    X1+X2
          SX7    B2 
          SA6    A1 
          SA7    A7+B5
          SA1    FV.LGO 
          SB1    1
          ZR     X1,EX.70A         IF BINARY OUTPUT OPTION OFF (B=0)
          WRITEW F.LGO,B6,B7
          SB5    B1+
 EX.70A   SA1    B4TMP
          SA2    A1+B5
          SB4    X1 
          SA3    A2+B5
          MX0    30 
          SA1    FREEMEM
          SA4    MEMEND 
          SB7    X1 
          IX4    X4-X1
          SA5    X2 
          SB6    X4 
          SA1    X3 
          SB2    X3 
          SB1    B0 
          EQ     DBB               EXIT 
  
* 
*         PROCESS LCM COMMON BLOCKS AND PRODUCE XFILL TABLES
* 
 EX.64    SA2    =XLEVEL2 
          ZR     X2,EX.80          IF NO LCM COMMON 
          SA2    FREEMEM
          SA3    MEMEND 
          MX0    30 
          SB4    22                INDEX FOR CORGTAB
          IX3    X3-X2             BUFFER SIZE
          SB7    X2                FWA BUFFER 
          SA1    CORGTAB
          SB1    B0                WORD COUNT 
          SX7    41B               XFILL TABLE
          SA5    X1-22
          SB6    X3 
          LX7    54 
          SA7    B7                STORE THE HEADER WORD
  
 EX.65    SA5    A5+B4             BLOCK HEADER WORD
          ZR     X5,EX.68          IF END OF COMMON BLOCKS
          SX1    X5 
          ZR     X1,EX.65          IF EMPTY CHAIN 
          SA4    A5+2 
          PL     X4,EX.65          IF NOT AN LCM BLOCK
  
          MX0    60-9 
          AX4    18 
          BX6    -X0*X4            EXTRACT RB ORDINAL 
          LX6    9
          SA6    RBC               SAVE RB CODE 
          EQ     EX.67
  
*         PROCESS AN LCM COMMON CHAIN 
  
 EX.66    ZR     B2,EX.65          IF END OF CHAIN
  
 EX.67    SA1    X1 
          LX1    30 
          SX6    X1                LOC FIELD, ADDRESS OF WHERE TO RELOC 
          AX1    18 
          MX3    60-9 
          BX4    -X3*X1            RL,ADDRESS RELOCATION TYPE 
          LX6    30          POSITION LOC FIELD 
          IX2    X6+X4             LOC,RL 
          AX1    9
          MX3    60-2 
          BX4    -X3*X1            EXTRACT POS VALUE
          LX4    4                 16*POS 
          BX3    -X3*X1            POS = 0,1,2
          IX6    X4-X3             15*POS = 0, 15, 30 
          LX6    24 
          SA3    XFL         F = (XFL) = LENGTH OF RELOCATION FIELD 
          BX2    X2+X6             LOC,POS,RL 
          LX3    18 
          IX4    X3+X2             LOC,POS,F,RL 
          SA3    RBC               RB CODE
          BX6    X4+X3             LOC,POS,F,RB,RL
          SB1    B1+B5             WC = WC + 1
          SA6    B7+B1             STORE THE XFILL ENTRY
  
          AX1    3
          SB2    X1                LINK TO NEXT CHAIN MEMBER
          LT     B1,B6,EX.66       IF BUFFER NOT FULL 
  
          RJ     DBB               DUMP BINARY BUFFER 
          SX7    41B               XFILL
          LX7    54 
          SA7    B7                RESET ID WORD IN TABLE 
          EQ     EX.66
  
*         DUMP ANY REMAINING XFILL TABLE
  
 EX.68    ZR     B1,EX.80          IF NO TABLE LEFT 
          RJ     DBB               DUMP BINARY BUFFER 
          EQ     EX.80
  
 RBC      DATA   0                 RB ORDINAL FOR LCM BLOCK 
* 
*         WRITE AN XFER TABLE 
* 
 EX.80    SA1    PROGRAM
          UX0    B1,X1
          NZ     B1,EX.90    IF NOT MAIN PROGRAM, SKIP XFER TABLE 
          SA1    XFRNAME           XFER NAME OR ZERO
          LX6    X1 
          CALL   RTB               REMOVE TRAILING BLANKS 
          SA1    FV.LGO 
          SB1    1
          SA6    XFERTAB+1
          ZR     X1,EX.90          IF BINARY OUTPUT OPTION OFF (B=0)
          WRITEW F.LGO,XFERTAB,2
          SB5    B1+
* 
*         PRINT THE END CARD
* 
 EX.90    SA1    OLIST
          ZR     X1,EX.100         JUMP IF O = 0
          SB1    B5 
          SB6    B0 
          RJ     WRLIST 
  
 EX.100   RJ     WEOR              WRITE AN EOR ON THE LGO FILE 
  
 EX.999   EQ     FTNXAS 
  
          END 
