*DECK     LISTIO
          IDENT  LISTIO 
 LISTIO   TITLE  LISTIO -    I/O STATEMENT PROCESSOR
*CALL     SSTCALL 
          SPACE  3
**        LISTIO - LIST DIRECTED I/O STATEMENT PROCESSOR. 
          SPACE  3
 B=LSTIO  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          ENTRY  DOITX,DONEX
 IXFNCL   ENTRY.
  
          EXT    DOCALL,DOIT,DONE,DODEF,DOGOOF,INTVAR,ERPROI
          EXT    IXFN,CONVERT,ERPRO,PH2RETN,RSELECT 
          EXT    LABCON,VTYPE,PSYM,CONDEC,F.LFN 
          EXT    DATA.,DIRECT,IOAPLN,L.IOLST,NCA,SAVDAN,ST. 
          EXT    O.IOLST
          EXT    KSSW,NTYPE,RSSW
          TABLES NML
  
 SYM1     EQU    12B
 DIM1     EQU    17B
 SELIST   EQU    32B
 CDCNT    EQU    37B
 PROGRAM  EQU    56B               PROGRAM/SUBPROGRAM FLAG
 NRLN     EQU    64B
  
          USE    /STSORD/          ST. STORE ORDINAL
 STSORD   BSS    1
          USE    *
  
 APLRST   ENTRY.
 BLEXP    ENTRY.
 HOLCON   ENTRY.
 INDFG    ENTRY.
 IOEXP    ENTRY. 0           AP. FORMAT, 24/P1,18/CA,18/IH
 IONAME   ENTRY.
 ITEMCT   ENTRY.
 PARCNT   ENTRY.
 TYPEFG   ENTRY.
 LDFLAG   ENTRY.             LIST-DIRECTED-I/O FLAG 
 BIO      ENTRY.                   BUFFER I/O FLAG
 CPLXC    ENTRY.             FLAGS CPLX CONST IN I/O LIST 
          EJECT 
 E.CUL    EQU    18                CONFLICTING USE OF A NAME
 E.DO13   EQU    13 
 E.BUN    EQU    26                BAD UNIT NUMBER
 E.IOSE   EQU    73                I/O STMT SYNTAX ERROR
 E.BFN    EQU    74                FORMAT NUMBER SYNTAX ERROR 
 E.LC     EQU    77                BAD SPEC FOR LINE CONTROL
 E.IONASA EQU    100               NON USAS I/O STMT
 E.EDC    EQU    107               CHAR COUNT ERROR IN EN/DECODE STMT 
 E.IOEXP  EQU    211               I/O EXPRESSIONS ARE NON ANSI 
 E.BIO    EQU    212               BUFFER I/O BETWEEN SCM AND LCM 
 E.BIO1   EQU    308               INFO FWA AND LWA ERROR IN BUFFER I/O 
 E.PIE    EQU    213               PARITY NUMBER MUST BE 0 OR 1 
 E.FNASA  EQU    223               FORMAT SPEC IS NON USAS
 E.IOND   EQU    309         I/O FILE NOT DEFINED 
 E.UNNIR  EQU    231               UNIT NUMBER NOT BETWEEN 1 AND 99 
 DO4      EQU    4                 DO CONTROL VARIABLE MUST B SIMP INTGR
 DO7      EQU    7                 DO PARM MUST BE INT CONST OR VARIABLE
 LISTIOC  EQU    75                ARRAY REFERENCE OUTSIDE DIM BIUNDS 
 ARTH136  EQU    136               VARIABLE FOLLOWED BY  (
 ARTH157  EQU    157               ARRAY REFERENCED WITH FEWER SUBSCRPTS
 ARTH195  EQU    195               TOO MANY SUBSCRIPTS IN ARRAY REFEREN 
 ARTH145  EQU    145               NO MATCHING RIGHT PARENTHESIS
 E.PIL    EQU    327         ILLEGAL SYNTAX IN IMPLIED DO SPEC
  
 CONLOC   DIS    1,1
 CON1     VFD    12/2000B,3/1,17/0,10/1,18/CONLOC 
 PLUS     VFD    12/2021B,48/6     + SIGN IN ELIST FOR MACRO IN COLAPR7 
          SPACE  2
*         EQU"S FOR THE RLIST MACROS TO CALL THE EXECUTION TIME I/O 
*         ROUTINES
  
 PIO      RMEQU  12B         I/O USE/DEF MACRO
 M.SXIT   RMEQU  6           IXFN SET 
 PIOMAX   EQU    29D         MAX NO. OF PARAMS IN PIO MACRO 
 BEFCALL  RMEQU  121B        BASIC EXT FUNC CALL MACRO ORDINAL
 GEFWOTR  RMEQU  123B        EXT CALL WITHOUT TRACEBACK MACRO ORDINAL 
 GEFMC    RMEQU  124B        GENERAL EXT FUNC CALL MACRO ORDINAL
 STAPL    RMEQU  127B        STORE TO APLIST MACRO ORDINAL
 M.IOAPL  RMEQU  343B        I/O APLIST COMBINER
 SSORI    RMEQU              SET, SHIFT OR
 MSORI    RMEQU              MASK-SHIFT-OR MACRO ORDINAL
 M.V1     RMEQU              BASE OF PRODUCT DIMENSIONS R-MACROS
 M.IOLWC  RMEQU  354B        BASE OF COLLAPSED I/O LIST WORD COUNT MACROS 
 M.INDLD  RMEQU  415B        INDIRECT MODE LOAD MACRO ORDINAL 
  
 GEFCM    RMHDR  GEFMC,2
 RJBEF    RMHDR  BEFCALL,1         MACRO HEADER FOR 30 BIT RJ 
 STRAPL   RMHDR  STAPL,3
 SETTYPE  RMHDR  SSORI,2
 SETVAR   RMHDR  MSORI,2
 GEFNT    RMHDR  GEFWOTR,2
  
 PARAMS   SPACE  4
*         FOLLOWING LOCATIONS ARE USED TO HOLD THE VALUES OF THE
*         PARAMETERS THAT ARE PACKED BY "MACOUT" TO FORM THE RLIST MACRO
  
 MACLS1                            ORDINAL OF EXECUTION TIME ROUTINE
 MACLS2                            ORDINAL OF LFN OR UNIT NUMBER
 MACLS3                            ORDINAL OF FORMAT NUMBER/NAMELIST GR 
 MACLS4 
  
 MACLP1                            VARIABLE PARITY
 MACLP2                            VARIABLE UNIT NUMBER 
 MACLP3                            VARIABLE FORMAT NUMBER 
 MACLP4 
 MACLP5 
 MACLP6 
  
 MACLK1                            -1 FOR FINAL CALL OR PARITY FOR BUFFI
 MACLK2                            WORD COUNT FOR INTERMEDIATE CALLS
 MACLK3                            BINARY LINE COUNT ( FIRST CALL ) 
 MACLK4                            TYPE OF THE SYMBOL 
 MACROS   SPACE  3
*         MP= - GENERATE AN R-NUMBER FOR A PARAMETER
*         OR SET THE VALUE OF A PARAMETER TO THE CONTENTS OF A
*         REGISTER OR A MEMORY CELL 
  
 MP=      MACRO  MP,EXP 
          LOCAL  MIC
          IFC    EQ,//EXP/,1
          ERR    MACRO MUST HAVE A SECOND PARAMETER 
 R        IFC    EQ,/EXP/NRLN/
  
*         EXP = NRLN, GENERATE AN R NUMBER FOR THE PARAMETER
  
          SA5    NRLN 
          BX6    X5 
          SX7    X5+B5
          SA6    MACL_MP           MP = NRLN
          SA7    A5                ADVANCE NRLN 
 R        ELSE
 C        IF     REG,EXP
  
*         EXP IS A REGISTER NAME
  
 MIC      MICRO  1,1,/EXP/
 RT       IFC    NE,/"MIC"/X/ 
          SX6    EXP
 MIC      MICRO  1,,/6/ 
 RT       ELSE
 MIC      MICRO  2,1,/EXP/
          IFLT   "MIC",6,2
          BX6    EXP
 MIC      MICRO  1,,/6/ 
 RT       ENDIF 
          SA"MIC"  MACL_MP         MP = EXP 
 C        ELSE
  
*         EXP IS A CONSTANT 
  
          SA5    EXP               LOAD IT
          BX6    X5 
          SA6    MACL_MP           MP = EXP 
 C        ENDIF 
 R        ENDIF 
          ENDM
          SPACE  2
*         MACRO TO FETCH AND STORE THE ARGUMENT COUNT BEFORE AND AFTER
*         EACH SVARG CALL TO PROCESS AN ARGUMENT
* 
 FORMARG  MACRO  TYPE,ARGNUM
          SA3    ARGCNT 
          SB7    X3 
          SVARG  TYPE,ARGNUM
          SX7    B7 
          SA7    ARGCNT 
          ENDM
          SPACE  2
*         MACRO TO PERFORM FMAC CALL, RESET THE ARGUMENT COUNT, AND 
*         UPDATE THE DATA. BLOCK COUNT
* 
 FORMMAC  MACRO  MACNAME
          OUTUSE DATA.
          SA2    ARGCNT 
          SA3    DATA.
          BX7    -X2
          SX6    X3+B5
          SA7    NARGS
          SA6    A3 
          MX7    0
          SA3    PARCNT 
          SA7    A2 
          SX6    X3+B5
          SA6    A3 
          FMAC   MACNAME
          ENDM
          EJECT 
*         SETS MACOP TO THE VALUE OF ARG
*         OR INCREMENTS MACOP IF ARG IS OF THE FORM:  
*         MACOP+XXX 
  
 MACOP=   MACRO  ARG
          LOCAL  MIC
 MIC      MICRO  1,6,/ARG/
  
 M        IFC    EQ,/"MIC"/MACOP+/
          SA3    MACOP
 MIC      MICRO  7,,/ARG/ 
          IFC    EQ,/"MIC"/1/,1 
 MIC      MICRO  1,,/B5/
          SX7    X3+"MIC" 
          SA7    A3                UPDATE MACOP 
  
 M        ELSE
          SX7    ARG
          SA7    MACOP
 M        ENDIF 
          ENDM
  
*         IXFN - MACRO TO CALL "IXFN" IN "ARITH"
* 
*         "IXFN" IS CALLED THE THE I/O STATEMENT PROCESSOR TO LOAD THE
*         ADDRESS OF A SYMBOL ( UNSUBSCRIPTED OR SUBSCRIPTED )
* 
 NOREF=   MICRO  1,,/MX2   60/     NO REFERENCE FLAG FOR IXFN 
  
 IXFN     MACRO  FLAG              CALL IXFN
 O        IFC    NE,//FLAG/ 
 I        IF     DEF,FLAG 
          SA2    FLAG 
 I        ELSE
          "FLAG=" 
 I        ENDIF 
 O        ENDIF 
          RJ     IXFNL
          ENDM
  
 ASAERR   MACRO                    POST ASA ERROR FOR NON USAS I/O STMT 
          SB6    -E.IONASA
+         SB7    *+1
          EQ     =XASAER
          ENDM
  
 FMT      MICRO  1,,/B5/           1S0 - FORMATTED I/O
 ^FMT     MICRO  1,,/B5+B5/        1S1
 BUF      MICRO  1,,/1S2/          BUFFER I/O 
 NAML     MICRO  1,,/1S3/          NAMELIST I/O 
 FREE     MICRO  1,,/1S4/          FREE FORM I/O
  
 FMODE    MACRO  MODE              SET FILE MODE
          SX5    "MODE" 
          RJ     SFMODE 
          ENDM
*CALL     PARSEM
*CALL     FMACDEF 
 STORAGE  SPACE  3
  
**
          PURGMAC STLTAB
 STLTAB   MACRO  DNAM 
 DNAM     =      .STL 
 .STL     SET    .STL+1 
 STLTAB   ENDM
  
 .STL     SET    0
  
*CALL,STLOAD
  
  
**        TABLE OF NAMES OF THE EXECUTION TIME ROUTINES 
*         ONE SHOULD NOTE THAT THIS TABLE IS INDEXED INTO BY USING
*         THE VALUE OF THE INPUT/OUTPUT FLAG ( "IOFLAG" ) AND 
*         THE BINARY/CODED OP FLAG
  
 NAME     MACRO  EPT,DNAM 
          LOCAL  D
 D        SET    DNAM  -2 
          VFD    12/2000B+D,48/8R_EPT 
 NAME     ENDM
  
  
 IOTAB    NAME   OUTBI.,STLOBI.    BINARY OUTPUT
          NAME   OUTBR. 
  
          NAME   OUTCI.,STLOCO.    CODED OUTPUT 
          NAME   OUTCR. 
  
          NAME   OUTFI.,STLOCO.    LIST-DIRECTED OUTPUT 
          NAME   OUTFR. 
  
          NAME   INPBI.,STLIBI.    BINARY INPUT 
          NAME   INPBR. 
  
          NAME   INPCI.,STLICO.    CODED INPUT
          NAME   INPCR. 
  
          NAME   INPFI.,STLICO.    LIST-DIRECTED INPUT
          NAME   INPFR. 
  
 EDTAB    NAME   ENCODI.           ENCODE 
          NAME   ENCODR.
  
          NAME   DECODI.           DECODE 
          NAME   DECODR.
  
 NAMLTAB  NAME   NAMOUT.,STLOCO.   NAMELIST OUTPUT
          NAME   NAMIN.,STLICO.    NAMELIST INPUT 
  
 BUFFTAB  NAME   BUFOUT.,STLOBU.   BUFFER OUT 
          NAME   BUFIN.,STLIBU.    BUFFER IN
  
 ENDFTAB  NAME   ENDFIL.,STLENF.   ENDFILE
 REWTAB   NAME   REWIND.,STLREW.   REWIND 
 BKSPTAB  NAME   BACKSP.,STLBAK.   BACKSPACE
          SPACE  4
 IOFLAG                            0 FOR A WRITE
*                                  1S59 FOR A READ
*                                  1 FOR A POSITIONING ROUTINE
  
 PIOFLAG  BSS    1           + IF ITEM DEFINED,- IF ITEM USED 
*                            ^0 IF ENTER NAME IN IOLST,0 OTHERWISE
 PIOBUF   BSS    1           TEMP FOR INDEX TO IOLST TABLE
 SYMORD   BSS    1           TEMP FOR SYMTAB ORD
 FMTORD   DATA   0           TEMP FOR FORMAT SYMTAB ORD 
 TINDX    BSS    1           INDEX TO IOLST (OR NML) TABLE
 TLEN     EQU    PIOBUF      COUNT FOR NO. OF PARAMS IN NML 
 CRFLAG   ENTRY. 0           ^0 IF AN ARRAY REF S/B CLASS REF 
 END=                              DEFAULT EOF LABEL CELL 
 TEMP                              A GENERAL TEMPORARY
 TEMPA                             SECOND GENERAL TEMPORARY 
 ARGCNT   BSS    1                 ARGUMENT COUNT FOR IOM MACRO 
  
 MACOP                             VALUE OF CURRENT MACRO OP
 MACBUF   BSS    18                MACRO BUFFER FOR RLIST 
  
 MACOPC   BSSZ   1                 COLLAPSE CODE MACRO NUMBER 
 LCMFG    BSSZ   2                 LEVEL FLAGS FOR BUFFER I/O 
 COLAPL   BSSZ   1                 COLLAPSE LOOP ITERATION NO.
 ARYADD   BSSZ   1                 ARRAY ADDRESS
 NAMDEX   BSSZ   3                 STORES THE INDICES...I,J,K 
 TENCOL   BSSZ   1                 TENATIVE COLLAPSE LEVEL
 NOCAL    BSSZ   1                 ADDRESS OF A NON COLLAPSIBLE ARRAY 
 COLLAPS  BSSZ   1                 ( COUNT = POSSIBLE COLLAPSE LEVEL
 ARNAM    BSSZ   1                 ARRAY NAME 
 DIMWRD   BSSZ   1                 WORD 2  OF THE DIM TABLE 
 DIMVAL   BSSZ   1                 DIMENSION SPECIFICATION VARIABLE 
 INDX     BSSZ   12                HOLDS I,I1,I2,I3,...ETC. 
 SAVELIS  BSSZ   1                 SAVE THE ELIS ADDRESS
 NODIMS   BSSZ   1                 NUMBER OF ARRAY DIMENSIONS AS DEFINED
 TEMP1    EQU    MACBUF      SYMTAB ORD FOR REF MAP 
 MACSYM   BSSZ   1           COUNT OF VARIABLE PARAMS IN I/O LOOP 
 COLAP    BSS    4           (EQUIVED) BASE OF ARRAY AND INDICES
 TEMPB    BSSZ   1           TEMPORARY FOR SUBSCRIPTS W/O INDIC5S 
 VFFLAG   BSSZ   1           VARIABLE FORMAT FLAG 
 TEMPBI   EQU    MACBUF+2    TEMPORARY FOR SUBSCRIPT BIAS 
 TEMPBA   EQU    MACBUF+7    TEMPORARY FOR SUBSCRIPT BASE 
 SNTI     BSS    1           NAME TABLE INDEX TEMP FOR PROFL
 UNITLIM  EQU    100         MAXIMUM UNIT NUMBER-1 ALLOWED
          TITLE              SUBROUTINES
*** 
*         IXFNL - LOCAL VERSION OF IXFN 
* 
*         ENTRY  X2 = REFMAP REFERENCE TYPE FLAG
*                X3 = EXPRESSION FLAG 
* 
*         EXIT
*                A0,A1,A2,X1,X2,B1,B2 SET AS IF EXITED FROM "SYMBOL"
*                X0 = V.DEF BIT 
*                X6 = NRLN-1  ( RESULT NUMBER FOR THE LOAD )
* 
 IXFNL    ENTRY. *                 ** ENTRY/EXIT ** 
          BX6    X2 
          CALL   IXFN 
          RJ     PLI
          SA3    SYM1 
          SB5    1
          SA0    X3 
          SB1    X2                B1 = SYMTAB ORDINAL
          SB2    B1+B1
          SA1    A0-B2
          SA2    A1-B5
          SA4    NRLN 
          SX6    X4-1 
          SX0    V.DEF
          EQ     IXFNL
          SPACE  2
*** 
*         IOSETUP - SETUP ROUTINE FOR I/O PROCESSING
* 
 IOSETUP  ENTRY. *                 ** ENTRY/EXIT ** 
          OUTUSE DATA.
          SA1    IOAPLN            I/O APLIST NUMBER
          SX2    X1+B5             INCREMENT TO X2 FOR NUMBER CALL
          BX6    X2 
          SA6    A1 
  
          SA4    =3R]IO 
          BX7    X4                SET UP RESULT FIELD
          SB1    42                SHIFT COUNT
          RJ     CNVT 
          SA4    =6LBSS 0B
          SX6    1R                BLANK FILL CHARACTER 
 FILL     LX7    6
          SB1    B1-6              DECREMENT SHIFT COUNT
          IX7    X7+X6             ADD FILL CHARACTER 
          NZ     B1,FILL           MORE FILL NEEDED 
  
          SB1    1
          BX6    X4 
          SA7    MACBUF 
          SA6    A7+B5
          WRITEC =XF.CMPS,MACBUF,2
  
          SX7    B0 
          SB5    B1 
          SA7    ARGCNT            RUNNING COUNT OF FORMARG CALLS 
          SA7    PARCNT            RUNNING COUNT OF I/O PARAMETERS
          SA7    PEDT        ENCODE-FLAG FOR *IOL*
          EQ     IOSETUP
          SPACE  3
*** 
*         CNVT - CONVERTS BINARY NUMBER IN X2 TO BCD, 
*         LEAVING RESULT IN X7 UPON EXIT
*         ON ENTRY B1 CONTAINS AN APPROPRIATE SHIFT COUNT 
* 
 CNVT     ENTRY.
          SX4    1R0
          SB2    6                 MAX CHARACTERS 
          LX2    42                POSITION BINARY NUMBER 
          MX5    57 
          SX6    B0 
 N1       SB2    B2-B5             CHARACTER COUNT
          NG     B2,CNVT           IF SIX CHARACTERS ALREADY PROCESSED
          LX2    3                 POSITION NEXT 3 BITS OF NUMBER 
          BX3    -X5*X2            EXTRACT BITS 
          NZ     X6,N2             IF NON ZERO CHARACTER
          ZR     X3,N1             IF LEADING ZERO
 N2       IX3    X4+X3             CONVERT TO DISPLAY CODE
          LX7    6                 POSITION RESULT WORD 
          SB1    B1-6              DECREMENT SHIFT COUNT
          IX7    X7+X3             ADD NEW CHARACTER
          SX6    B5                SET NON ZERO CHARACTER FOUND 
          EQ     N1 
          EJECT 
*** 
*         CFSIV - CHECK FOR SIMPLE INTEGER VARIABLE 
* 
*         ON ENTRY: 
*                B6 = ERROR NUMBER
*                X1,X2 = WORDS A AND B OF SYMTAB ENTRY
* 
*         EXITS WITH X3 = 0 IF SYMBOL IS A SIMPLE INTEGER VARIABLE
*         ELSE IT EXITS TO ERPRO
* 
 CFSIV    ENTRY. *                 ** ENTRY/EXIT ** 
          BX0    X1 
          LX0    59-P.DIM 
          NG     X0,CFSIV1         ERROR IF DIMENSIONED 
          BX0    X2 
          AX0    P.TYP
          SX3    X0-T.INT 
          ZR     X3,CFSIV          EXIT IF INTEGER
  
 CFSIV1   SX2    B1 
          RJ     PSYM              SET UP X3 AND X4 
 IOERRX   SB7    PH2RETN
          EQ     ERPRO
  
 CFSIV    MACRO  ERNUM             MACRO TO CALL CFSIV
          SB6    ERNUM
          RJ     CFSIV
          ENDM
          SPACE  3
*** 
*         NAMLIST - PROCESS NAMLIST I/O 
* 
*         ON ENTRY: 
*                B1 = SYMTAB ORDINAL OF THE NAMELIST GROUP NAME 
*                X2 = WORD B OF GROUP NAME
* 
 NAMLIST  ENTRY. *                 ** ENTRY/EXIT ** 
          GETE
          IF.NE  EL.EOS,IOERR  IF NOT *EOS* 
          RJ     ONI         OUTPUT NAMELIST ITEMS TO RLIST 
          SX6    B1 
          SA6    TEMP 
          FORMARG NAME,1
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
          SA5    RSELECT
          ZR     X5,NAMLIST1       IF R = 0 
          ADDREF TEMP,REF          ADD REFERENCE FOR THE GROUP NAME 
  
 NAMLIST1 FMODE  NAML              SET THE FILE MODE
          SA3    IOFLAG 
          LX3    1
          SA1    NAMLTAB+X3        FETCH NAME OF EXECUTION TIME ROUTINE 
          RJ     IOLIST 
          EQ     NAMLIST
          TITLE  PVARNAM - PROCESS VARIABLE NAMES 
*** 
*         PVARNAM - PROCESS VARIABLES USED AS FILE, PARITY
*         INDICATOR, FORMAT, OR CHAR COUNT NAMES
*         ISSUE APPROPRIATE IOM MACRO FOR THE NAME
* 
*         ON ENTRY -  B4 - 0 IF FILE/PARITY NAME
*                          1 IF FMT, CHAR COUNT NAME
*                     X1 - WORD A OF SYMTAB ENTRY FOR NAME
*                     X2 - WORD B 
* 
 PVARNAM  ENTRY. *                 ** ENTRY/EXIT ** 
          BX7    X2 
          LX2    -P.LCM      LCM/ECS RESIDENT FLAG
          MX6    -1 
          BX6    -X6*X2 
          LX2    P.LCM       REPOSITION 
          SB3    X6          LCM INDICATOR
          SA7    LCMFG+B7 
          SB2    59-P.FP
          LX0    B2,X1
          ZR     B3,PVN0     IF NOT LCM 
          ZR     B4,PVN3     IF FILE NAME OR PARITY INDICATOR 
 PVN0     PL     X0,PVN3     IF NOT F.P.
          SX6    B1-2              F.P. OFFSET
          FORMARG OCT,2 
          NZ     B4,PVN1           IF NOT A FILE/PARITY NAME
          SX6    B5 
          FORMARG INT,5 
          SA3    LDFLAG 
          SX6    X3          1 IF WRITE OR PUNCH, 0 OTHERWISE 
          ZR     X6,PVARNAM  IF NOT WRITE OR PUNCH
          FORMARG INT,6 
          EQ     PVARNAM
 PVN1     ZR     B3,PVN2           IF NOT AN LCM VARIABLE 
          SX6    B5 
          FORMARG INT,5 
 PVN2     SX6    B5 
          FORMARG INT,6 
          SA1    NCA               CONSTANT ADDEND
          BX6    X1 
          FORMARG OCT,7 
          EQ     PVARNAM
 PVN3     BSS    0
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          ZR     B3,PVN5           IF NOT AN LCM VARIABLE 
          NZ     B4,PVN4           IF NOT FILE/PARITY NAME
          MX7    0
          SA7    MACSYM            REQUIRED FOR EQUIVP CALL 
          RJ     EQUIVP            SEE IF EQUIVALENCED
          MP=    S1,X6             SYMTAB ORDINAL TO S1 
          MP=    K1,X7             CA TO K1 
          MP=    P1,NRLN           RESULT NUMBER TO P1
          SA1    ST.               ORDINAL OF ST. 
          BX6    X1 
          MP=    S2,X6             PLACE IN S2
          FORMARG NAME,1
          SA1    STSORD            CA FOR ST. 
          BX6    X1 
          SX7    X1+B5
          SA7    A1                RESTORE INCREMENTED VALUE
          MP=    K2,X6             PLACE IN K2
          FORMARG OCT,2 
          SX6    B5 
          FORMARG INT,5            SET VAR BIT
          SA3    LDFLAG 
          SX6    X3          1 IF WRITE OR PUNCH, 0 OTHERWISE 
          ZR     X6,PVN3A    IF NOT WRITE OR PUNCH
          FORMARG INT,6 
  
 PVN3A    BSS    0
          MX6    0
          SA6    MACOPC 
          MACOP= M.INDLD     INDIRECT MODE LOAD 
          RJ     MACOUT            ISSUE MACRO
          EQ     PVARNAM
 PVN4     SA3    DIRECT 
          ZR     X3,PVN5           IF DIRECT MODE 
  
          RJ     FII         FORM INDIRECT-MODE IOM ITEM
          SX6    B5 
          FORMARG INT,5            SET LCM BIT
          SX6    B5 
          FORMARG INT,6            SET VAR BIT
          EQ     PVARNAM
 #DAL     ENDIF 
  
 PVN5     RJ     EQUIVP      FIND BASE AND BIAS OF NAME 
          SB2    X7 
          FORMARG NAME,1
          SA1    NCA               CONSTANT ADDEND
          SX6    X1+B2             CA + EQUIV BIAS
          FORMARG OCT,2 
 PVN6     ZR     B4,PVN7           IF A FILE/PARITY NAME
          ZR     B3,PVN8           IF NOT AN LCM VARIABLE 
 PVN7     SX6    B5 
          FORMARG INT,5 
          NZ     B4,PVN8     IF NOT FILE/PARITY NAME
          SA3    LDFLAG 
          SX6    X3          1 IF WRITE OR PUNCH, 0 OTHERWISE 
          ZR     X6,PVARNAM  IF NOT WRITE OR PUNCH
 PVN8     SX6    B5 
          FORMARG INT,6 
          EQ     PVARNAM
 FII      TITLE  FORM INDIRECT MODE LCM IOM ITEM. 
**        FII--FORM INDIRECT MODE IOM ITEM. 
* 
*         FII FORMS FIRST TWO ARGUMENTS (BASE AND BIAS) OF AN IOM 
*         MACRO FOR AN LCM VARIABLE IN INDIRECT MODE.  THESE ARGUMENTS
*         REPRESENT BASE AND BIAS RESPECTIVELY. 
* 
*         ENTRY - (X1) = SYMTAB WORD A OF ITEM. 
*                 (X2) =        WORD B OF ITEM. 
* 
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
 FII      ENTRY. *
          SX6    1
          SA6    =XIAF       FOR FMAC 
          SX6    B1          SYMTAB ORDINAL 
          FORMARG  NAME,1 
          SA3    NCA
          BX6    X3 
          FORMARG OCT,2 
          EQ     FII
 #DAL     ENDIF 
          TITLE              FMTNO - PROCESS FORMAT NUMBER
 ASAFLAG
*** 
*         FMTNO - PROCESS FORMAT NUMBER 
* 
*         ON ENTRY: 
*                SELIST POINTS TO FORMAT NUMBER 
* 
*         ON EXIT:  
*                B1 = SYMTAB ORDINAL OF FORMAT NUMBER OR GROUP NAME 
*                X3 = INDEX INTO I/O NAME TABLE 
* 
  
 FMTNOX   SA5    RSELECT
          ZR     X5,FMTNOX1        IF NO LONG MAP 
          SA2    TEMP 
          ADDREF X2,REF            ADD A REFERENCE FOR THE NAME 
  
 FMTNOX1  FMODE  FMT               SET FILE MODE
          SX3    2                 INDEX TO I/O TABLE 
  
          SA1    TEMP              SYMTAB ORDINAL 
          SB1    X1 
          MX0    59 
  
 FMTNO    ENTRY. *                 ** ENTRY/EXIT ** 
          ADVIN                    GET CURRENT ELEMENT
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          IF.NE  NAME,FMTNO.C      IF NOT A NAME
          SYMBOL                   SEARCH SYMTAB FOR THE NAME 
          EQ     FMTNO.F           FIRST OCCURANCE
  
 FMTNO1   MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP
          SX0    X3-T.NML 
          ZR     X0,FMTNO          EXIT IF NAMELIST 
  
          BACKE                    BACK UP E-LIST POINTER 
  
          SX7    B5 
          SA7    CRFLAG      SPECIAL CASE CLASS REF CHECK 
          SX3    B5                NO EXPRESSION FLAG 
          MX6    59 
          SA6    IXFNCL      SIGNAL VARIABLE FORMAT 
          SA6    VFFLAG      SET VARIABLE FORMAT FLAG 
          IXFN   REF               PROCESS NAME 
          SX0    V.DIM
          SX7    B1 
          BX0    X0*X1
          SA7    TEMP 
          BX7    X0 
          SA4    APLRST 
          SA7    ASAFLAG           NON-ZERO IF DIM
          ZR     X4,FMTNO1A        STORE TO APLIST NOT NEEDED 
          SA1    SETVAR            MACRO TO SET VAR BIT FOR FORMAT WORD 
          SA3    NRLN              NEXT AVAILABLE R NUMBER
          LX6    16                RF NUMBER FROM ARRAY LOAD
          BX7    X1+X3             MACRO HEADER 
          BX6    X6+X3             R NUMBERS
          SX1    B5                MASK VALUE 
          SA7    MACBUF 
          SX4    58                SHIFT COUNT
          SA6    A7+B5
          LX4    18 
          BX7    X4+X1             CONSTANT NUMBERS 
          SX6    X3+B5             INCREMENT R NUMBER 
          SA7    A6+B5
          SB4    3                 MACRO WORD COUNT 
          SA6    A3 
          BX6    X3                RESULT NAME FOR STORE TO APLIST
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     FMTNO3 
  
 FMTNO1A  SB4    B5                SET FOR FMT NAME 
          SB7    B5 
          RJ     PVARNAM           PROCESS FORMAT NAME
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
 FMTNO3   SA3    ASAFLAG
          NZ     X3,FMTNOX1        IF DIM 
  
          SB6    -E.FNASA          NON-ANSI VARIABLE FORMAT 
          SB7    FMTNOX1
          EQ     ASAER
  
 FMTNO.F  ZR     X7,FMTNO.F1       IN NO PREVIOUS USE IN DEBUG STMTS
          CFO    VAR               CHECK SETTING OF DEBUG BITS
  
 FMTNO.F1 SX0    B5 
          IX2    X6+X2             SET TYPE 
          LX0    P.VAR
          BX7    X0+X2             SET VAR BIT
          SA7    A2 
          EQ     FMTNO1 
  
*         PROCESS CONSTANT FORMAT NUMBER
  
 FMTNO.C  SB6    -E.BFN            BAD FORMAT NUMBER
          IF.NE  CON,FMTNO.FF      IF NOT A CONSTANT
          AX1    45 
          SX2    X1-T.INT 
          SA1    X4                FETCH CONSTANT 
          AX4    18 
          SB1    X4                CHARACTER COUNT
          SB2    B1-6 
          NZ     X2,IOERRX         IF NOT AN INTEGER CONSTANT 
          PL     B2,IOERRX         IF MORE THAN 5 DIGITS
  
+         SB7    *+1
          EQ     LABCON            GO CONVERT NUMBER AND ENTER IN SYMTAB
          EQ     FMTNO2            FIRST OCCURANCE
  
          SX0    M.FNCHK
          LX0    P.FNCHK           DSN , RAS AND DLT
          BX3    X0*X2
          SB6    E.CUL
          NZ     X3,CFSIV1         IF PREVIOUSLY USED AS A STMT LABEL 
  
 SLAB     BIT    P.TYP-P.RFN
 FMTNO2   SX0    T.LAB*SLAB+1 
          LX0    P.RFN
          BX7    X0+X2             SET TYPE AND RFN BITS
          SA7    A2 
          SX6    B1                SYMTAB ORDINAL 
          FORMARG NAME,1
          SX7    B1 
          SA7    TEMP 
          SA7    FMTORD      SAVE FORMAT SYM ORD FOR RLIST
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          EQ     FMTNOX            GO ADD A REFERENCE FOR THIS LABEL
  
 FMTNO.FF IF.NE  EL.STAR,IOERRX 
          FMODE  FREE              SET FILE MODE
          SB6    -E.FNASA 
+         SB7    *+1         RETURN ADDRESS 
          EQ     ASAER       LIST-DIRECTED FORMAT NON-ANSI
          MX6    1
          SA6    LDFLAG      LIST-DIRECTED FORMAT 
          MX0    59 
          SX3    4                 INDEX TO I/O TABLE 
          EQ     FMTNO
          SPACE  3
 TAPEN    VFD    12/0,48/4LTAPE 
 UNITF                             UNIT/PARITY INDICATOR
  
 UNITN.E  SB6    -E.BUN            BAD UNIT NUMBER
          EQ     IOERRX 
 UNITN.B  SB6    -E.UNNIR          UNIT NUMBER OUT OF RANGE 
          EQ     IOERRX 
          TITLE              UNITN - PROCESS UNIT NUMBER
*** 
*         UNITN - PROCESS UNIT NUMBER OR PARITY INDICATOR 
*         ON ENTRY: 
*                X7 = 0 IF UNIT/ 1 IF PARITY
* 
*         ON EXIT:  
*                X3 = 0 IF VARIABLE PARITY, ELSE X1 = BINARY NUMBER 
* 
 UNITN    ENTRY. *                 ** ENTRY/EXIT ** 
          SA7    UNITF             SAVE UNIT/PARITY FLAG
          GETE                     GET E LIST ELEMENT 
          IF.EQ  CON,UNITN.C       IF A CONSTANT
          IF.NE  NAME,UNITN.E      IF NOT A NAME
  
*         PROCESS VARIABLE UNIT/PARITY INDICATOR
  
          NEXTE                    GET NEXT E 
          IF.EQ  EL.),UNITN1
          IF.NE  EL.COMMA,UNITN.E  IF NOT A ) OR ,
  
 UNITN1   SX7    B5 
          SX3    B5 
          SA7    IXFNCL      PROCESSING UNIT NAME IN READ/WRITE 
          IXFN   FREF              PROCESS NAME 
          CFSIV  E.BUN             CHECK FOR A SIMPLE INTEGER VARIABLE
          SB4    B0                SET FOR FILE/PARITY NAME 
          SB7    B5 
          RJ     PVARNAM           PROCESS FILE/PARITY NAME 
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          MX3    0                 RESULT OF CFSIV CALL 
          EQ     UNITN             EXIT IF OK 
  
*         PROCESS CONSTANT UNIT/PARITY INDICATOR
*         UNIT NUMBER - CONVERT FILE NAME TO TAPEN# AND CALL PLFN 
  
 UNITN.C  UPDATE                   ADVANCE E-LIST POINTER 
          AX1    45 
          SX2    X1-T.INT 
          NZ     X2,UNITN.E        IF NOT TYPE INTEGER
          BX1    X4 
          SB1    -B5
          RJ     CONVERT           CONVERT TO BINARY
          SA3    UNITF
          NZ     X3,UNITN          EXIT IF PARITY 
          =X2    UNITLIM
          IX2    X1-X2
          PL     X2,UNITN.B  IF UNIT NUMBER .GT. 99 (ERROR) 
          SB1    1
          CALL   CDD               RETURNS (X6) = DPC CONVERTED INTEGER 
          SA2    TAPEN
          SX7    1R"C"-1R 
          SB5    B1 
          LX6    6
          SB3    18 
          IX6    X6+X7             NN"C"
          SB4    B3-B2
          LX5    B4,X6             POSITION TO BIT 24 
          MX0    36 
          BX4    -X0*X5            4R NN"C" 
          BX1    X2+X4             8RTAPENN"C"
          RJ     PLFN              PROCESS THE FILE NAME
          EQ     UNITN
          EJECT 
*** 
*         PLFN - PROCESS FILE NAME
* 
*         ON ENTRY: 
*                X1 = 8R_FILE NAME
* 
  
 PLFN1    SA3    F.LFN             FILE NAME BITS 
          BX7    X3+X2
          SA7    A2                UPDATE WORD B OF SYMTAB
  
          SX7    A2 
          SA7    LFNA        SAVE ADDRESS OF WORD B 
          SA6    LFNB        SAVE I/O FILE NAME 
  
          SA3    F.LFN
          SA4    PROGRAM
          LX3    59-P.EXT 
          UX0    B7,X4
          NG     X3,PLFN2          IF FILES OPTION NOT SELECTED 
  
*         FILES OPTION - ENTER FILE NAME IN CON TABLE 
  
          MP=    S2,B1             SAVE SYMTAB ORDINAL
  
          MX0    1                 DELETE TRAILING BLANKS FROM THE NAME 
          SB7    18 
          MX7    60-6 
+         AX2    B7,X1
          BX3    -X7*X2 
          SX4    X3-1R
          SB7    B7+6 
          ZR     X4,*-1            LOOP IF A BLANK
          SB7    B7-59             DELETE TRAILING "C" CHARACTER
          LX0    B7,X0             MASK(LNAME)
          BX1    X0*X1             EXTRACT NAME 
          SB1    B5 
          CALL   CONVERT           ENTER IN THE CONTABLE
          SX6    X1                SYMTAB ORD 
          FORMARG NAME,1
          AX1    30 
          SX6    X1                CA 
          FORMARG OCT,2 
          SX6    B5 
          FORMARG INT,5 
          SA3    LDFLAG 
          SX6    X3          1 IF WRITE OR PUNCH, 0 OTHERWISE 
          ZR     X6,PLFN1A   IF NOT WRITE OR PUNCH
          FORMARG INT,6 
  
 PLFN1A   BSS    0
          SA1    MACLS2 
          SB1    X1                RESTORE B1 
          EQ     PLFN3
  
 PLFN2    SX6    B1                SYMTAB ORDINAL 
          FORMARG NAME,1
          SA3    LDFLAG 
          SX6    X3          1 IF WRITE OR PUNCH, 0 OTHERWISE 
          ZR     X6,PLFN3    IF NOT WRITE OR PUNCH
          FORMARG INT,6 
  
 PLFN3    SA5    RSELECT
          ZR     X5,PLFN4          IF R = 0 
          SA2    IOFLAG            READ/WRITE/POS FLAG
          RJ     ADDREF            ADD A REFERENCE TO THE FILE
  
 PLFN4    FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          SA3    PROGRAM
          UX6    B7,X3
          NZ     B7,PLFN     IF NOT A MAIN PROGRAM
          SA3    LFNB 
          ZR     X3,PLFN     IF I/O FILE DEFINED
          POSTER NR=E.IOND,SEV=INF,FMT=DPC,TXT=X3 
  
 PLFN     ENTRY. *                 ** ENTRY/EXIT ** 
          SYMBOL   ,PLFN5 
 PLFN5    EQ     PLFN6
  
 +        EQ     PLFN7
  
 PLFN6    BX3    X1 
          AX3    18 
          SA4    =3L
          BX6    X4+X3       (X6) = TAPE NUMBER 
          EQ     PLFN1
  
 PLFN7    MX6    0
          EQ     PLFN1+1
  
  
 LFNA     DATA   0           ADDRESS OF WORD B
 LFNB     DATA   0           I/O DEVICE NUMBER(H FORMAT)
*** 
*         SFMODE - SET FILE MODE BITS 
*         ON ENTRY:   X5 = BIT TO BE SET RIGHT JUSTIFIED
* 
 SFMODE   ENTRY. *                 ** ENTRY/EXIT ** 
          SA4    LFNA 
          ZR     X4,SFMODE         EXIT IF LAST OP USED A VARIABLE UNITN
          SA4    X4 
          LX5    P.FMODE
          BX6    X5+X4
          SA6    A4 
          EQ     SFMODE 
 IOCM     SPACE  3,14 
**        IOCM - OUTPUT CALL TO I/O ROUTINE 
* 
*         ENTRY  (X1) = 12/2000B+STLTAB ORD, 48/8R RUN-TIME I/O ROUTINE 
  
 IOCMA    VFD    L.TYP/T.CGS
          POS    P.EXT+1
          VFD    1/1
          POS    P.IOF+1
          VFD    1/1,*P/0 
  
 IOCM     ENTRY. *
          UX1,B2 X1 
          MI     B2,IOCM2    IF *LDSET USE=* NOT NEEDED 
          MX6    1           SELECT DECK NAME FOR STATIC LOAD DIRECTIVE 
          SA2    =XSTLTAB+B2
          BX6    X6+X2
          SA6    A2 
 IOCM2    SYMBOL
          SA3    IOCMA
          BX7    X3+X2       SET EXT AND IOF BITS 
          SA7    A2 
          SA3    IONAME 
          AX3    18 
          SA1    X3                MACRO HEADER 
          SA4    IOAPLN 
          BX6    X1 
          SA6    MACBUF             BUFFER FOR MACRO
          SX1    B1 
          SX3    X4+I.IO
          SA2    CDCNT             LINE NUMBER
          LX3    30 
          BX7    X3+X1
          SA7    A6+B5             WORD 1 OF MACRO
          BX7    X2 
          SA7    A7+B5
          WRM    MACBUF      I/O CALL MACRO TO RLIST
          EQ     IOCM 
          TITLE              ENDFILE, BACKSPACE AND REWIND STMT PROCESSI
,NG 
*         ENDFILE - PROCESS "ENDFILE" STATEMENT 
  
 ENDFILE  ENTRY.
          RJ     IOSETUP
          SA1    ENDFTAB
          RJ     PERB 
          EQ     ENDFILE
  
*         REW - PROCESS "REWIND" STATEMENT
  
 REW      ENTRY.
          RJ     IOSETUP
          SA1    REWTAB 
          RJ     PERB 
          EQ     REW
  
*         BKSP - PROCESS "BACKSPACE" STATEMENT
  
 BKSP     ENTRY.
          RJ     IOSETUP
          SA1    BKSPTAB
          RJ     PERB 
          EQ     BKSP 
          SPACE  3
*** 
*         PERB - COMMON PROCESSOR FOR ENDFILE,REWIND AND BACKSPACE
*         STATEMENTS
* 
*         ON ENTRY: 
*                X1 = NAME OF EXECUTION TIME ROUTINE
* 
 PERB     ENTRY. *                 ** ENTRY/EXIT ** 
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          BX7    X1 
          SA7    TEMP              SAVE NAME OF ROUTINE 
          SX6    B5 
          SA6    IOFLAG            SET FOR POSITIONING REF
          RJ     DOCALL            INFORM DO PROCESSOR OF EXT CALL
  
          SA5    SELIST 
          SA4    X5-1 
          UX1    B2,X4
          IF.NE  EL.EOS,IOERR      IF NOT AN EOS AFTER FILE NAME/NUMBER 
          SX6    2000B+EL.) 
          LX6    48 
          SA6    A4                FUDGE IT FOR UNITN 
          MX7    0
          MX6    60 
          SA6    PIOFLAG
          RJ     UNITN             PROCESS THE UNIT NUMBER
          RJ     IIR         SHOW USE OF VAR UNIT NUMBER
          SA1    TEMP              ROUTINE NAME 
          SX6    GEFCM             MACRO HEADER ADDRESS 
          LX6    18 
          SA6    IONAME 
          RJ     IOCM              GO OUTPUT MACRO TO RLIST 
          MX6    0
          SA6    IONAME            CLEAR FOR NEXT I/O STMT
          EQ     PERB 
  
          TITLE  PRINT AND PUNCH STMT PROCESSING
*         THE FOLLOWING ARE CONSIDERED TO BE ALTERNATE FORMS. 
*           PRINT( )
*           PUNCH( )
  
*         PUNCH N,LIST
  
 PUNCH.L  MX7    2
          LX7    1           PUNCH AND ALTERNATE FORM BITS ARE SET
          SA7    LDFLAG 
          ASAERR             PUNCH( ) NON-ANSI
          MX6    0
          RJ     PRORW
  
 PUNCH    ENTRY.
          RJ     IOSETUP
          GETE
          IF.EQ  EL.(,PUNCH.L 
          SX7    B5          PUNCH BIT SET
          SA7    LDFLAG 
          SA1    =8RPUNCH"C"       FILE NAME
          RJ     PROFL
          EQ     PUNCH
  
*         PRINT N,LIST
  
 PRINT.L  ASAERR             PRINT( ) NON-ANSI
          MX7    1
          SA7    LDFLAG      ALTERNATE FORM BIT SET 
          MX6    0
          RJ     PRORW
  
 PRINT    ENTRY.
          RJ     IOSETUP
          GETE
          IF.EQ  EL.(,PRINT.L 
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          SA1    =8ROUTPUT"C"      FILE NAME
          RJ     PROFL
          EQ     PRINT
          SPACE  3
**        PROFL - PROCESS I/O STMTS OF THE FORM  "KEYWORD" N,LIST 
*         ENTRY  (X1) = 12/IOFLAG,48/8R_NAME OF ASSOC FILE
  
 PROFL.N  RJ     NAMLIST
  
 PROFL    ENTRY. *                 ** ENTRY/EXIT ** 
          MX0    12 
          BX6    X0*X1
          SA6    IOFLAG            SET I/O FLAG 
          SA6    END= 
          MX7    60 
          SA7    PIOFLAG
          RJ     PLFN              PROCESS THE FILE NAME
          ASAERR                   FLAG NON USAS USEAGE 
          RJ     DOCALL 
          SA4    COMMA
          SA5    SELIST            STORE COMMA IN SELIST-1 TO AVOID 
          BX6    X4                GETTING UNWANTED INFORMATIVE 
          SA6    X5+B5             DIAGNOSTIC FROM ARITH
          RJ     FMTNO             PROCESS THE FORMAT NUMBER
          ZR     X0,PROFL.N        IF NAMELIST
          BX6    X3 
          SA6    SNTI        SAVE NAME-TABLE INDEX
  
          GETE                     GET NEXT E-LIST ELEMENT
          IF.NE  EL.EOS,PROFL1  IF NOT EOS
          SA2    LDFLAG 
          ZR     X2,PROFL2   IF NO IOLIST, AND NOT LIST DIRECTED IO 
          EQ     IOERR       IF NO IOLIST, AND LIST DIR IO. 
 PROFL1   IF.NE  EL.COMMA,IOERR  ERROR IF NOT A , 
          IF.NE  EL.COMMA,IOERR    ERROR IF NOT A , 
          UPDATE
          GETE
          IF.EQ  EL.EOS,IOERR 
          IF.EQ  EL.COMMA,IOERR    IF A COMMA PRECEDING LIST
  
 PROFL2   SA2    IOFLAG 
          SA3    SNTI 
          LX2    3                 0 OR 4 
          AX7    B5,X2             0 OR 2 
          BX2    X2+X7             0 OR 6 
          IX0    X2+X3
          SA1    IOTAB+X0          ADDRESS OF ROUTINE NAMES 
          RJ     IOLIST            PROCESS THE I/O LIST 
          EQ     PROFL
          TITLE              READ AND WRITE STMT PROCESSING 
 INPUTF   VFD    12/1S11,48/8RINPUT"C"
 COMMA    VFD    12/2003B,48/0     ELIST REPRESENTATION FOR A COMMA 
  
*** 
*         READ - PROCESS READ STATEMENTS
* 
*         SYNTAX: 
*                READ N,LIST       CODED READ OF INPUT
*                READ (U) LIST     BINARY 
*                READ (U,N) LIST   CODED
*                READ (U,X)        NAMELIST READ
* 
  
 READ.F   SA1    INPUTF            FILE NAME AND FLAG 
          RJ     PROFL
 READ     ENTRY.
          RJ     IOSETUP
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          GETE                     GET FIRST E-LIST ELEMENT 
          IF.NE  EL.(,READ.F       IF FIRST IS NOT A (
          MX6    1
          RJ     PRORW
          EQ     READ 
          SPACE  3
*** 
*         WRITE - PROCESS WRITE STATEMENTS
* 
*         SYNTAX: 
*                WRITE (U) LIST    BINARY WRITE 
*                WRITE (U,F) LIST  CODED WRITE
*                WRITE (U,X)       NAMELIST WRITE 
  
 WRITE.L  SX7    1           WRITE BIT SET
          SA1    =8ROUTPUT"C" 
          SA7    LDFLAG 
          RJ     PROFL
  
 WRITE    ENTRY.
          RJ     IOSETUP
          GETE
          IF.NE  EL.(,WRITE.L 
          SX7    B5          WRITE BIT SET
          SA7    LDFLAG 
          MX6    0
          RJ     PRORW
          EQ     WRITE
          EJECT 
*** 
*         PRORW - PROCESS I/O STMTS OF THE FORM "KEYWORD" ( ), LIST 
* 
*         ON ENTRY: 
*                X6 = VALUE OF IOFLAG ( 0 OR 1S59 ) 
* 
  
 PRORW.N  RJ     NAMLIST           PROCESS NAMLIST I/O
          ASAERR
  
 PRORW    ENTRY. *                 ** ENTRY/EXIT ** 
          SA6    IOFLAG 
          SA6    END= 
          MX7    60 
          SA7    PIOFLAG
          RJ     DOCALL            INFORM DO PROCESSOR OF EXT CALL
          ADVIN                    ADVANCE E-LIST POINTER 
          IF.NE  EL.(,IOERR        ERROR IF NOT A ( 
          MX7    0
          SA7    LFNA 
          RJ     UNITN             PROCESS UNIT NUMBER
  
          ADVIN 
          IF.EQ  EL.),PRORW.B      IF A BINARY OPERATION
          IF.NE  EL.COMMA,IOERR    ERROR IF NOT A , 
          RJ     FMTNO             PROCESS FORMAT NUMBER
  
          ADVIN                    ADVANCE E-LIST POINTER 
          IF.NE  EL.),IOERR        ERROR IF NOT A ) 
          ZR     X0,PRORW.N        IF A NAMELIST OP 
  
          SA2    IOFLAG 
 PRORW1   LX2    3                 0 OR 4 
          AX7    B5,X2             0 OR 2 
          BX2    X2+X7             0 OR 6 
          IX0    X2+X3
          GETE
          IF.EQ  EL.COMMA,IOERR    IF A COMMA PRECEDING LIST
          SA1    IOTAB+X0          ADDRESS OF ROUTINE NAMES 
          RJ     IOLIST 
          EQ     PRORW
  
 PRORW.B  SA3    LDFLAG 
          MI     X3,IOERR    IF OF ALTERNATE FORM 
          FMODE  ^FMT        SET THE FILE MODE
          SA2    IOFLAG 
          MX3    0
          EQ     PRORW1 
          TITLE              BUFFER IN/OUT STMT PROCESSING
*         BUFIN - PROCESS "BUFFER IN" STATEMENT 
  
 BUFIN    ENTRY.
          RJ     IOSETUP
          MX7    1
          RJ     PBUF 
          EQ     BUFIN
  
*         BUFOUT - PROCESS "BUFFER OUT" STATEMENT 
  
 BUFOUT   ENTRY.
          RJ     IOSETUP
          MX7    0
          RJ     PBUF 
          EQ     BUFOUT 
          SPACE  3
*** 
*         PBUF - COMMON PROCESSOR FOR BUFFER IN/OUT STATEMENTS
* 
*         SYNTAX: 
*                BUFFER XX (U,P) (FWA,LWA)
* 
  
 PBUF     ENTRY. *                 ** ENTRY/EXIT ** 
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          SA7    IOFLAG            SET I/O FLAG 
          MX6    60 
          SA6    PIOFLAG
          RJ     DOCALL            INFORM DO PROCESSOR
          ASAERR                   FLAG NON USAS STMT 
          ADVIN                    SKIP LEADING ( 
  
          MX7    0
          SA7    LFNA 
          RJ     UNITN             PROCESS THE UNIT NUMBER
          FMODE  BUF               SET THE FILE MODE
  
          ADVIN 
          IF.NE  EL.COMMA,IOERR    ERROR IF NOT A , 
          SX7    1
          RJ     UNITN             PROCESS PARITY 
          ZR     X3,PBUF1          IF VARIABLE PARITY 
          SX2    X1-2 
          SB6    -E.PIE 
          PL     X2,IOERRX         IF PARITY \ 2
          SB1    B5 
          RJ     CONVERT           PLACE PARITY INDICATOR IN CON TABLE
          SX6    X1                SYMTAB ORDIANL 
          FORMARG NAME,1
          AX1    30 
          SX6    X1                CA 
          FORMARG OCT,2 
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
 PBUF1    GETE               GET NEXT E 
          IF.NE  EL.),IOERR        IF NOT A ) 
          NEXTE 
          UPDATE
          IF.NE  EL.(,IOERR        IF NOT A ( 
          SA2    IOFLAG 
          MX7    2
          LX7    1
          ZR     X2,PBUF1A   IF BUFFER OUT
          MX6    0
          SA6    PIOFLAG           FLAG WILL INDICATE DEF 
  
 PBUF1A   SX3    B5          NO EXPRESSION FLAG 
          SX6    B5 
          SA7    BIO         FLAG BUFFER FWA
          SA6    CRFLAG      SPECIAL CASE CLASS REF CHECK 
          IXFN   IOFLAG            CALL IXFN TO OUTPUT A LOAD FOR FWA 
          SX7    B1                SYMTAB ORD 
          SA3    IOFLAG 
          SA7    TEMP 
          ZR     X3,PBUF2          IF NOT AN INPUT OP 
          BX7    X1+X0             SET DEFINED BIT
          SA7    A1 
  
 PBUF2    SA4    APLRST 
          ZR     X4,PBUF2A         STORE TO APLIST NOT NEEDED 
          BX7    X2 
          SA7    LCMFG+1
          SB4    B0                WORD COUNT FOR WRITE CALL
          SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     PBUF2B 
  
 PBUF2A   SB4    B5 
          SB7    B5 
          RJ     PVARNAM           PROCESS AS IF FORMAT NAME
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
 PBUF2B   ADVIN 
          IF.NE  EL.COMMA,IOERR    IF NOT A , 
          SX3    B5                NO EXPRESSION FLAG 
          MX6    1
          SA6    BIO               FLAG BUFFER LWA
          IXFN   IOFLAG            CALL IXFN TO LOAD LWA+1
          SX7    B1          SYMTAB ORD 
          SA3    IOFLAG 
          SA7    TEMPA
          ZR     X3,PBUF3          IF NOT AN INPUT OP 
          BX7    X0+X1
          SA7    A1 
  
 PBUF3    SA4    APLRST 
          ZR     X4,PBUF3A         STORE TO APLIST NOT NEEDED 
          BX7    X2 
          SA7    LCMFG
          SB4    B0                WORD COUNT FOR WRITE CALL
          SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     PBUF3C 
  
 PBUF3A   SB4    B5 
          SB7    B0 
          RJ     PVARNAM           PROCESS AS IF FORMAT NAME
          FORMMAC  IOM       OUTPUT IOM TO COMPS
  
 PBUF3C   SA1    LCMFG
          SA2    A1+B5
          BX6    X1-X2
          LX6    59-P.LCM 
          PL     X6,PBUF4    IF LEVEL OF FWA AND LWA AGREE
          SB6    -E.BIO            ERROR IF FWA/LWA IN DIFFERENT LEVELS 
          SB7    PH2RETN
          EQ     ERPRO
  
 PBUF4    ADVIN 
          IF.NE  EL.),IOERR        IF NOT A ) 
          NEXTE 
          IF.NE  EL.EOS,IOERR      IF NOT EOS 
  
          RJ     IIR         ISSUE IOLIST TABLE TO RLIST IF OPT=2 
          SA3    IOFLAG 
          SX6    GEFCM             MACRO HEADER ADDRESS 
          LX3    1
          SA1    BUFFTAB+X3        NAME OF OBJECT ROUTINE 
          LX6    18 
          SA6    IONAME 
          RJ     IOCM              OUTPUT MACRO 
          SA5    TEMP        SYMTAB ORD OF FWA
          MX6    0
          SA6    IONAME      CLEAR FOR NEXT I/O PROCESSOR 
          SA2    SYM1 
          LX0    X5,B5       2*SYMTAB ORD 
          SB1    X5 
          IX6    X2-X0
          SA1    X6          WORD A OF FWA
          SA6    TEMP 
          SA2    A1-B5       WORD B 
          RJ     EQUIVP      RETURN IH OF FWA 
          SA3    IOFLAG 
          SA6    MACLS2      BASE OF FWA
          SA2    SYM1 
          LX6    1
          SX6    X6+B5
          LX3    1+P.LOCF 
          IX6    X2-X6
          SA1    X6          WORDB OF BASE OF FWA 
          BX6    X1+X3       SET LOCF BIT TO INHIBIT OPTIMAZATION FOR 
          SA6    A1          INPUT OPERATION
          SA3    TEMPA       SYMTAB ORD OF LWA
          IX5    X3-X5
          ZR     X5,PBUF     IF SYMTAB ORD(FWA)  EQ  SYMTAB ORD(LWA)
          SA2    SYM1 
          LX0    X3,B5       2*SYMTAB ORD 
          SB1    X3 
          IX6    X2-X0
          SA1    X6          WORD A OF LWA
          SA6    A3 
          SA2    A1-B5       WORD B 
          RJ     EQUIVP      RETURNS IH OF LWA
          SA5    MACLS2      IH OF FWA, STORED BY EQUIVP
          MX0    1
          IX6    X5-X6
          ZR     X6,PBUF     IF IHS EQUAL 
          SA3    MACBUF+1    SYMTAB ORD OF OBJECT ROUTINE NAME
          SA2    SYM1 
          SX5    X3 
          LX5    1
          IX1    X2-X5
          SA2    X1-1        WORD B OF SYMTAB ENTRY 
          LX0    P.IOF+1
          BX6    -X0*X2      CLEAR IOF BIT IN WORD B
          SA6    A2 
          SA4    TEMPA
          SA2    TEMP 
          SA3    X4          WORD A OF LWA
          SA1    X2          WORD A OF FWA
          BX6    X1*X3
          LX6    59-P.FP
          MI     X6,PBUF     IF FWA AND LWA ARE F.P.
          LX6    P.FP-P.COM 
          PL     X6,BUFERR   IF EITHER NOT IN COMMON BLOCK
          SA2    A1-B5       WORD B OF FWA
          SA4    A3-B5       WORD B OF LWA
          MX6    -L.RB
          BX5    X2-X4
          LX6    P.RB 
          BX0    -X6*X5 
          ZR     X0,PBUF     IF SAME COMMON BLOCK 
 BUFERR   POSTERR   NR=E.BIO1,SEV=INF,RETURN=PBUF 
 PSTAPL   TITLE  PROCESS STORE TO APLIST MACROS 
          SPACE  2
*** 
*         PSTAPL - PROCESS STORE TO APLIST MACROS 
* 
*         ON ENTRY - X2 - WORD B OF VARIABLE LOADED 
*                    B4 - MACRO BUFFER WORD COUNT.
*                    X6 - RESULT NUMBER OF LOAD FROM IXFN 
*                    A7 - NEXT RLIST STORE ADDRESS
* 
 PSTAPL   ENTRY. *                 ** ENTRY/EXIT ** 
          SA1    STRAPL      STORE TO APLIST MACRO HEADER 
          SA3    IOAPLN 
          BX7    X1+X6
          SA7    A7+B5
          SX7    X3+I.IO
          SA7    A7+B5             IH FOR I/O APLIST
          SA6    A7+B5             RESULT NUMBER
          SA1    PARCNT            PARAMETER COUNT
          SX7    X1 
          SA7    A6+B5             BIAS FOR STORE 
          SB4    B4+4              ADJUST WORD COUNT
          SB1    1
          WRITEW =XF.RLST,MACBUF,B4      MACRO TO -RLIST- 
          SX6    0
          SB5    1
          SA6    APLRST            CLEAR FLAG 
          EQ     PSTAPL 
 STIOM    SPACE  4,8
**        STIOM - FORM MACRO TO INDICATE A STORE TO AN APLIST WORD
  
 STIOM    ENTRY. *                 ** ENTRY/EXIT ** 
          SB1    1
          WRITEC =XF.CMPS,IOM.CD,2
          SA2    DATA.
          SA1    PARCNT 
          SB5    1
          SX7    X2+B5
          SX6    X1+B5
          SA7    A2                INCREMENT BLOCK SIZE 
          SA6    A1                INCREMENT PARAMETER COUNT
          EQ     STIOM
 IOM.CD   LIT    13C  IOM     -1B 
          TITLE              ENCODE/DECODE STMT PROCESSING
*         DEC - PROCESS "DECODE" STATEMENT
  
 DEC      ENTRY.
          RJ     IOSETUP
          MX7    1
          RJ     PED
          EQ     DEC
  
*         ENC - PROCESS "ENCODE" STATEMENT
  
 ENC      ENTRY.
          RJ     IOSETUP
          MX7    0
          RJ     PED
          EQ     ENC
          SPACE  3
 PED.E    SB6    -E.EDC            BAD CHARACTER COUNT
          EQ     IOERRX 
  
*** 
*         PED - COMMON PROCESSOR FOR ENCODE AND DECODE STMTS
* 
*         SYNTAX: 
*                XXCODE (C,N,V) LIST
  
 PEDT     BSS    1           IOLST ENTRY FOR ENCODE *V* 
  
 PED      ENTRY. *                 ** ENTRY/EXIT ** 
          MX6    0
          SA6    LDFLAG      CLEAR LIST-DIRECTED FLAG 
          SA7    IOFLAG 
          MX6    60 
          SA6    PIOFLAG
          RJ     DOCALL            INFORM DO PROCESSOR
          ASAERR                   FLAG NON USAS STMT 
          ADVIN                    SKIP LEFT PAREN
          GETE                     GET NEXT 
          IF.NE  CON,PED.VC        IF CHAR COUNT IS NOT A CONSTANT
  
*         PROCESS CONSTANT CHAR COUNT 
  
          UPDATE
          AX1    45 
          SX2    X1-T.INT 
          NZ     X2,PED.E          IF NOT TYPE INTEGER
          SB1    -B5
          BX1    X4 
          RJ     CONVERT           CONVERT CHAR COUNT TO BINARY 
          ZR     X1,PED.E          IF ZERO
          SB1    B5 
          RJ     CONVERT           PLACE CHAR COUNT IN CON TABLE
          SX6    X1                SYMTAB ORDINAL 
          FORMARG NAME,1
          AX1    30 
          SX6    X1                CA 
          FORMARG OCT,2 
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          EQ     PED1 
  
*         VARIABLE CHAR COUNT 
  
 PED.VC   IF.NE  NAME,PED.E        IF NOT A NAME
          NEXTE                    GET NEXT E 
          IF.NE  EL.COMMA,PED.E    IF NOT A , 
  
          SX3    B5                NO EXPRESSION FLAG 
          IXFN   REF               PROCESS NAME 
          CFSIV  E.EDC             CHECK FOR A SIMPLE INTEGER VARIABLE
          SB4    B5                SET FOR CHAR COUNT NAME
          SB7    B5 
          RJ     PVARNAM           PROCESS CHAR COUNT NAME
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
 PED1     ADVIN                    ADVANCE E-LIST POINTER 
          IF.NE  EL.COMMA,IOERR    IF NOT A , 
          GETE
          IF.EQ  EL.STAR,IOERR
          MX7    0
          SA7    LFNA 
          RJ     FMTNO             PROCESS FORMAT NUMBER
          ZR     X0,IOERR          NAMELIST NOT ALLOWED 
  
          ADVIN 
          IF.NE  EL.COMMA,IOERR    IF NOT A , 
          SA1    IOFLAG 
          NZ     X1,PED1A          IF DECODE
          MX7    0
          SA7    PIOFLAG           +0 IF ENCODE 
 PED1A    MX0    1
          BX2    -X1*X0            SET FLAG FOR IXFN
          SX3    B5                NO EXPRESSION FLAG 
          MX6    59 
          SA6    IXFNCL      SIGNAL VARIABLE FORMAT 
          SX6    B5 
          SA6    BIO         FLAG ENCODE/DECODE 
          SA6    CRFLAG      SPECIAL CASE CLASS REF CHECK 
          IXFN                     GET ADDR OF V
          SA3    PIOFLAG
          MI     X3,PED2           IF A DECODE STMT 
          BX7    -X3
          SA7    A3 
          BX7    X0+X1
          SA7    A1                SET DEFINED BIT
  
*         FILING OF *DEF* ENTRY IN *IOLST* FOR V IS DEFERRED UNTIL
*         THE LIST IS PROCESSED SO THAT USES WILL NOT BE LOST.
  
          SA3    =XOPT2 
          ZR     X3,PED2     IF OPT .NE. 2
          SA3    L.IOLST
          SA4    O.IOLST
          SB4    X3-1 
          SX7    B4 
          SA4    X4+B4
          SA7    A3          L.IOLST = L.IOLST - 1
          BX7    X4 
          SA7    PEDT        HOLDS IOLST ENTRY FOR *V* UNTIL IOL
  
 PED2     SA4    APLRST 
          ZR     X4,PED2A          STORE TO APLIST NOT NEEDED 
          SB4    B0                WORD COUNT FOR WRITE CALL
          SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     PED2B
  
 PED2A    SB4    B5 
          SB7    B5 
          RJ     PVARNAM           PROCESS AS IF FORMAT NAME
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
 PED2B    ADVIN 
          IF.NE  EL.),IOERR        IF NOT A ) 
  
          SA3    IOFLAG 
          LX3    2                 0 OR 2 
          SA1    EDTAB+X3 
          RJ     IOLIST            PROCESS THE I/O LIST 
          EQ     PED
          SPACE  2
 IOERR    SB6    E.IOSE            I/O STMT SYNTAX ERROR
          SB7    DOGOOF 
          MX6    0
          SA6    IONAME            CLEAR FOR NEXT I/O STMT
          EQ     ERPRO
          TITLE              IOLIST - I/O LIST PROCESSING 
 SERF                              SINGLE ELE REF FLAG. 0 IF NEXT IS (
  
*** 
*         IOLIST - I/O LIST PROCESSOR 
*           PROCESSES THE I/O LIST AND OUTPUTS MACROS TO RLIST TO CALL
*           THE EXECUTION TIME ROUTINES TO TRANSFER THE DATA TO/FROM
*           THE I/O DEVICES 
* 
*         ON ENTRY: 
*                A1 = ADDRESS OF 2 WORDS CONTAINING NAMES OF EXECUTION
*                TIME ROUTINES
*                SELIST POINTS TO FIRST ELEMENT OF LIST 
*                MACLS1 - MACLK3 SET FOR FIRST CALL 
* 
 IOLIST   ENTRY. *                 ** ENTRY/EXIT ** 
          SX7    GEFCM             MACRO HEADER ADDRESS 
          SX6    A1 
          LX7    18 
          BX6    X6+X7
          MX7    0
          SA6    IONAME            ADDRESS OF OBJECT ROUTINE NAMES
          SA7    HOLCON      CLEAR FLAG IN CASE SET BY PREVIOUS I/O STMT
          SA3    IOFLAG 
          ZR     X3,IOLIST1        IF ^INPUT
          SX6    1
          SA6    PIOFLAG           + FOR ITEMS DEFINED
  
 IOLIST1  SA1    END= 
          ZR     X1,IOL.L          IF NOT A READ STATEMENT
          SA2    =XN.GL      NEXT #GL NUMBER
          SA4    =3R#GL 
          SB1    24                SHIFT COUNT
          BX7    X4 
          RJ     CNVT              CONVERT TO BCD STRING
          LX6    B1,X7
          FORMARG CHAR,1
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          SPACE  2
*         MAIN LOOP 
  
 IOL.L    GETE                     GET E LIST ELEMENT 
          IF.EQ  NAME,IOL.N  IF A NAME
          IF.EQ  EL.(,IOL.C 
          IF.NE  EL.EOS,IOL.N      IF NOT AN END OF STATEMENT 
          SPACE  3
*         END OF STMT - ISSUE TERMINAL CALL 
  
 IOL.E    SA4    A4+B5       PREVIOUS ELIST ELEMENT 
          MX6    0
          SA6    VFFLAG      RESET VARIABLE FORMAT FLAG 
          UX1    B2,X4
          IF.NE  EL.COMMA,IOL.E0   IF NOT LINE CONTROL
          SA2    LDFLAG 
          SB6    -E.LC       LINE CONTROL SPEC
          SA1    IOFLAG 
          PL     X2,IOERRX   LINE CONTROL ALLOWED ONLY FOR * FORMAT 
          NZ     X1,IOERRX   NOT ALLOWED FOR INPUT STMT 
          SX6    1           SIGNAL ENTRY WITH NO BASE
          FORMARG OCT,1 
          SX6    7           TYPE = 7 FOR LINE CONTROL
          FORMARG OCT,3 
          FORMMAC IOM 
 IOL.E0   SA1    PEDT 
          ZR     X1,IOL.E1   IF NOT ENCODE
          ADDWD  IOLST,X1    FILE *DEF* ENTRY FOR *V* 
  
 IOL.E1   RJ     IIR         ISSUE IOLST TABLE TO RLIST 
          SB1    1
          WRITEC =XF.CMPS,EIOP.CD,2 
          SA2    DATA.
          SB5    1
          SX6    X2+B5             INCREMENT BLOCK SIZE 
          SA6    A2 
          SA4    IONAME 
          MX6    0
          SA1    X4 
          SA6    L.IOLST           RESET TABLE LENGTH 
          RJ     IOCM 
          MX6    0
          SA6    IONAME            CLEAR FOR NEXT I/O STMT
  
          SA2    END= 
          ZR     X2,IOLIST         IF NOT A READ STATEMENT
          SA6    A2                CLEAR
          SA2    N.GL 
          SX7    X2+B5       N.GL = N.GL + 1
          SA7    A2 
          SX5    X2+I.GL
          CALL   WLABM       WRITE LABEL DEF TO RLIST 
          EQ     IOLIST 
  
  
 EIOP.CD  LIT    12C  EIO     0B
 IOL.N    SPACE  3
*         PROCESS NAME
  
 IOL.N    NEXTE                    GET NEXT ELEMENT 
          IF.EQ  EL.=,DOEND        IF =, THEN CLOSE OUT THE LOOP
          SX7    B2-EL.(
          SA7    SERF              SAVE SINGLE ELEMENT REF FLAG 
  
          SA3    IOFLAG      ^0 IF INPUT, USED AS EXPRESSION FLAG 
          IXFN   IOFLAG            CALL IXFN TO LOAD THE ADDR 
          MP=    P1,X6             P1 = R NUMBER OF RESULT OF LOAD
  
          SA3    IOFLAG 
          ZR     X3,IOL.N1         IF NOT AN INPUT OP 
          BX6    X0+X1             SET DEFINED BIT
          SA6    A1 
          SX7    A1 
          SX6    B1 
          SA7    TEMP              SAVE ADDRESS OF WORD A 
          SA6    TEMPA             SAVE SYMTAB ORDINAL
          RJ     DODEF             INFORM DO OF VARIABLE REDEFINITION 
          SA3    TEMP 
          SA1    X3                RESTORE SYMTAB ENTRY 
          SA2    A1-B5
          SA4    TEMPA
          SA3    MACLP1 
          BX6    X3                RESTORE RESULT NUMBER
          SB1    X4                RESTORE SYMTAB ORDINAL 
  
*         EXTRACT TYPE AND SET SDPF ( SINGLE/DOUBLE PRECISION FLAG )
  
 IOL.N1   SA4    APLRST 
          NZ     X4,LSTARR         IF ARRAY STORE TO APLIST 
          SA5    IOEXP
          NZ     X5,LSTEXP         IF LIST EXPRESSION 
          SA4    HOLCON 
          NZ     X4,LSTCON         IF HOLLERITH CONSTANT
          SA3    TYPEFG            TYPE WORD
          SX6    X3+B5             TYPE + 1 
          SA6    MACLK4            SAVE IN PARAMETER K4 
          MX4    1
          BX7    X4*X3             SINGLE/DOUBLE PRECISION BIT
          LX7    1
          SB3    X7                SDPF 
  
*         COMPUTE THE WORD COUNT FOR THE TRANSFER 
  
          SA3    SERF 
          SX6    B5                ITEM COUNT = 1 
          ZR     X3,IOL.N2         IF NEXT WAS A (
  
          SB2    59-P.DIM 
          LX0    B2,X1
          PL     X0,IOL.N3         IF NOT DIMENSIONED 
  
*         GET DIM ENTRY AND CHECK FOR VARIABLE DIMENSIONS 
  
          BX7    X2 
          SA7    TEMP              SAVE WORD B OF SYMTAB ENTRY
          MX0    60-L.DIMP
          LX2    60-P.DIMP
          SA4    DIM1 
          BX5    -X0*X2            EXTRACT DIMP ORDINAL 
          LX5    1
          SB4    X5+B5
          LX2    P.DIMP            REPOSITION 
          SA5    X4+B4             SECOND WORD OF DIM ENTRY 
          MX0    3
          BX3    X0*X5
          LX0    60-3 
          BX4    X0*X5             VAR DIM FLAG V(ABC)
          LX3    3                 X3 = NUMBER OF DIMENSIONS
          NZ     X4,IOL.VAX        IF VARIABLE DIMENSIONS 
          AX5    36 
          SX6    X5                X6 = PRODUCT OF DIMENSIONS 
          SA3    TYPEFG 
          PL     X3,IOL.N2         IF SINGLE WORD ARRAY 
          AX6    1                 ITEM COUNT = WORD COUNT/2
  
 IOL.N2   SA6    ITEMCT            SAVE THE ITEM COUNT
  
          RJ     LSTITM            PROCESS LIST ITEM
          EQ     IOL.NE 
  
 IOL.N3   SA4    IOFLAG 
          ZR     X4,IOL.N2         IF NOT AN INPUT STATEMENT
          SA3    TEMP              RESTORE SYMTAB ENTRY 
          SA4    TEMPA             RESTORE SYMTAB ORDINAL 
          SA1    X3 
          SB1    X4 
          SA2    A1-B5
          SX6    B5                ITEM COUNT = 1 
          EQ     IOL.N2 
          SPACE  3
*         GET NEXT ELEMENT
  
 IOL.NE   ADVIN                    GET NEXT AND ADVANCE E-LIST POINTER
          IF.EQ  EL.COMMA,IOL.L    IF COMMA 
          IF.EQ  EL.EOS,IOL.E      IF EOS 
          IF.NE  EL.S),IOERR       IF NOT A SPECIAL PAREN 
          EQ     IOL.NE            LOOP 
          SPACE  3
  
 IOL.VAX  SB3    B0          FORCE SINGLE PRECISION FOR ITEM COUNT
          MX7    1
          RJ     WWC         GENERATE RMACRO TO COMPUTE WORD COUNT
          SA2    TEMP              RESTORE WORD B 
          SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          SA3    NRLN 
          SB4    B0                WORD COUNT FOR WRITE CALL
          SX6    X3-1              RESULT NUMBER OF LAST MACRO
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     IOL.NE 
          SPACE  3
 DOITX    EQU    IOL.L             RETURN POINT FOR DOPROC AFTER
*                                  PROCESSING THE BEGINNING OF AN 
*                                  IMPLIED LOOP.
          SPACE  3
*         SET UP STORE TO APLIST ENTRY WITH TYPE FIELD
  
 LSTARR   SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          LX0    X6 
          MX6    0
          SA6    A4                CLEAR FLAG 
          SB4    B0                WORD COUNT FOR WRITE CALL
          SA1    SETTYPE           MACRO HEADER 
          SA3    NRLN              NEXT AVAILABLE RESULT NUMBER 
          LX0    16 
          BX7    X1+X3
          SA7    A7+B5
          BX6    X0+X3
          SA6    A7+B5             RESULT NUMBERS 
          SX5    48                SHIFT COUNT
          SA1    TYPEFG            TYPE WORD
          LX5    18 
          SX4    X1+B5             ADJUST FOR APLIST ENTRY
          BX7    X5+X4
          SA7    A6+B5             CONSTANT NUMBERS 
          SX6    X3+B5             INCREMENT RESULT NUMBER
          SB4    B4+3              ADJUST WORD COUNT
          SA6    A3 
          BX6    X3                RESULT NAME FOR STORE TO APLIST
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
          EQ     IOL.NE 
          SPACE  3
*         SET UP APLIST ENTRY FOR LIST EXPRESSION 
  
 LSTEXP   SX6    B1                SYMTAB ORDINAL 
          MX7    0
          SA7    A5                CLEAR FLAG 
          AX5    18 
          FORMARG NAME,1
          SX6    X5                ST. BIAS 
          FORMARG OCT,2 
          SA1    TYPEFG 
          SX2    X1-T.OCT 
          NG     X2,LSTEXP1        NOT OCTAL OR HOLLERITH EXPRESSION
          SX1    B5                FORCE TYPE INTEGER 
  
 LSTEXP1  SX6    X1+B5             ADJUST FOR APLIST
          FORMARG OCT,3 
          SX6    B5                ITEM COUNT 
          FORMARG OCT,4 
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
  
          SA1    TYPEFG 
          SA2    NRLN 
          PL     X1,LSTEXP2        IF TYPE OF RESULT IS NOT DBL OR CMPLX
          SX6    X2+B5
          SA6    A2 
 LSTEXP2  SA5    SELIST            GET NAME FOR MESSAGE 
          SA4    X5+B5
          SB6    E.IOEXP           I/O EXPRESSIONS ARE NON ANSI 
          SB7    IOL.NE 
          EQ     ASAER
          SPACE  3
*         SET UP APLIST ENTRY FOR HOLLERITH CONSTANT
  
 LSTCON   SX6    X4                SYMTAB ORDINAL 
          MX7    0
          SA7    A4                CLEAR FLAG 
          FORMARG NAME,1
          AX4    18 
          SX6    X4                BIAS FIELD 
          AX4    18 
          FORMARG OCT,2 
          MX0    57 
          BX6    -X0*X4      TYPE OF HOL STRING 
          FORMARG OCT,3 
          AX4    6
          SX6    X4          WORD COUNT OR CHAR. COUNT
          FORMARG OCT,4 
          FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          EQ     IOL.NE 
          SPACE  3
*         SET UP APLIST ENTRY FOR I/O LIST ITEM 
  
 LSTITM   ENTRY. *                 ** ENTRY/EXIT ** 
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          LX2    -P.LCM      LCM/ECS RESIDENT FLAG
          MX7    -1 
          BX6    -X7*X2 
          LX2    P.LCM       REPOSITION 
          SB3    X6                LCM INDICATOR
 #DAL     ELSE
          SB3    B0                *** SIMULATE NON LCM MDOE ***
 #DAL     ENDIF 
          SB7    59-P.FP
          LX0    B7,X1
          AX0    59                SIGN EXTEND
          SB4    X0-0              FP INDICATOR 
          PL     X0,LSTITM1        IF NOT A FORMAL PARAMETER
          SX6    B1-2              F.P. OFFSET
          FORMARG OCT,2 
          EQ     LSTITM3
  
 LSTITM1  BSS    0
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          ZR     B3,LSTITM2        IF NOT AN LCM VARIABLE 
          SA3    DIRECT 
          ZR     X3,LSTITM2        IF DIRECT MODE 
          RJ     FII         FORM INDIRECT-MODE IOM ITEM IH,CA
          EQ     LSTITM3
 #DAL     ENDIF 
  
 LSTITM2  RJ     EQUIVP      FIND BASE AND BIAS OF NAME 
          SB2    X7 
          FORMARG NAME,1
          SA1    NCA               CONSTANT ADDEND
          SX6    X1+B2             CA + EQUIV BIAS
          FORMARG OCT,2 
  
 LSTITM3  SA3    TYPEFG            TYPE WORD
          SX4    X3-T.OCT 
          NG     X4,LSTITM3A       IF NOT GREATER THAN TYPE DOUBLE
          SX3    B5                FORCE TYPE INTEGER 
  
 LSTITM3A SX6    X3+B5             INCREMENT FOR APLIST 
          FORMARG OCT,3 
          SA4    ITEMCT            ITEM COUNT 
          MX7    0
          BX6    X4 
          SA7    A4                CLEAR
          FORMARG OCT,4 
          ZR     B3,LSTITM4        IF NOT AN LCM VARIABLE 
          SX6    B5                LCM BIT
          FORMARG INT,5 
  
 LSTITM4  SA4    INDFG             INDIRECT INDICATOR 
          ZR     X4,LSTITM5 
          MX7    0
          SX6    B5                INDIRECT BIT 
          SA7    A4                CLEAR
          FORMARG INT,6 
          SX6    X4                INDIRECT BASE FIELD
          FORMARG NAME,7
          EQ     LSTITM6
  
 LSTITM5  PL     B4,LSTITM6        IF NOT A FORMAL PARAMETER
          SA1    NCA               CONSTANT ADDEND
          ZR     X1,LSTITM6        NO CA FIELD
          BX6    X1 
          FORMARG OCT,7 
  
 LSTITM6  FORMMAC IOM              ISSUE MACRO TO COMPS FILE
          EQ     LSTITM 
 WWC      EJECT 
**        WWC - WRITE WORD COUNT. 
* 
*         ARRAY TRANSFER WITH VARIABLE DIMENSIONS.
*         FORM RLIST MACROS TO COMPUTE THE SIZE, OR ITEM COUNT, 
*         OF THE ARRAY. 
* 
*         ENTRY  (X3) = NUMBER OF DIMENSIONS
*                (X4) = VARIABLE DIMENSION FLAGS - P(ABC) 
*                (X5) = SECOND WORD OF DIM ENTRY
*                (X7) = IOF = 0 IF NO IOAPL MACRO TO BE OUTPUT
*                (B3) = SDPF,  =0 TO FORCE ITEM COUNT CALCULATION 
  
 WWC      ENTRY. ** 
          CX6    X4          (X6) = NUMBER OF VARIABLE DIMENSIONS 
          SA7    WWCA 
          IX2    X6-X3
          SB6    MACBUF 
          AX2    59          (X2) = SIGN(N.VDIMS - N.DIMS)
          SX0    B5 
          BX7    X2*X0
          SX1    B3          SDPF 
          BX7    X7+X1       CONF = 1 IF CONSTANT DIM OR DOUBLE WORD
*                            ARRAY; ELSE 0
          IX2    X7+X7
          SX0    4
          IX2    X7+X2       3*CONF 
          IX2    X2+X6
          SB2    X2+M.V1-1   RMACRO NUMBER = BASE + N.VD + 3*CONF 
  
          LX0    30          IN FIELD = N.WORDS IN MACRO BODY 
          SB2    -B2
          PX7    B2,X0
          SA7    B6          RMACRO HEADER WORD 
  
*         STORE SYMTAB ORDINALS IN THE MACRO CALL.
  
          SX2    X6-3 
          MI     X2,WWC1     LESS THAN 3 VARIABLE DIMENSIONS
          SX6    X5 
          AX5    18 
          SX1    X5 
          LX1    RM.IHL 
          BX6    X1+X6       30/IH(DIM2),30/IM(DIM1)
          AX5    18 
          SX7    X5          30/IH(DIM3)
          SA6    B6+B5       STORE SYMTAB ORDINALS
          SA7    A6+B5
          MX7    0           NO CONTANTS NEEDED 
          EQ     WWC5 
  
 WWC1     SX7    B5+B3
          SB4    X3          NUMBER OF DIMENSIONS 
          MX6    0           INITIALIZE RESULT REGISTERS
          PX7    X7 
          LX4    2           POSITION VARIABLE DIM BITS 
          SB2    0           SHIFT COUNT
  
*         PACK ARGUMENTS FOR RLIST MACRO. 
  
 WWC2     SX1    X5          EXTRACT DIM
          LX4    1
          SB4    B4-B5       DECREMENT THE NUMBER OF DIMS 
          AX5    18 
          MI     X4,WWC3     IF VARIABLE DIM
          PX0    X1 
          DX7    X7*X0       ACCUMULATED PRODUCT OF CONSTANT DIMS 
          NZ     B4,WWC2
          EQ     WWC4 
  
 WWC3     LX1    B2,X1       POSITION SYMTAB ORDINAL
          BX6    X1+X6
          SB2    B2+RM.IHL
          NZ     B4,WWC2     LOOP IF MORE DIMS
  
 WWC4     SA6    B6+B5       WORDS 1 AND 2 = SYMTAB ORDINALS
          MX6    0
          SA6    A6+B5
          SX7    X7 
 WWC5     SA7    B6+4        WORD 4 = PRODUCT OF CONSTANT DIMS
  
          SA5    NRLN 
          BX7    X5 
          SA7    A7-B5       WORD 3 = NRLN */ R-NUMBER OF RESULT
          SX6    X5+B5       NRLN = NRLN + 1
          SA6    A5 
          SB1    B5 
          WRM    B6          OUTPUT PI DIMS MACRO 
          SA1    WWCA 
          ZR     X1,WWC      IF IOF = 0    */ ITEM COUNT COMPUTATION
  
          SA5    NRLN 
          BX6    X5          RESULT R-NUMBER
          SX1    X5-1        ITEM COUNT R-NUMBER = NRLN - 1 
          SX7    X5+B5       NRLN = NRLN + 1
          SA7    A5 
          SA2    MACLP1      RESULT R-NUMBER FROM IXFN CALL 
          LX6    RM.RIL 
          BX7    X6+X2
          LX7    RM.RIL 
          BX7    X7+X1
          SA7    WWCA 
          SA1    MACLK4      ARRAY TYPE 
          BX6    X1 
          SA6    A7+B5
          WRM    IOAPL       OUTPUT IOAPL MACRO 
          EQ     WWC
  
 IOAPL    RMHDR  M.IOAPL,2
 WWCA     BSS    2
          SPACE  4
          TITLE              IMPLIED DO PROCESSING
 BI=      MACRO  BI,ECODE          SBI  ECODE 
          S_BI   ECODE
 ECODE    MICRO  1,,/BI/
          ENDM
          SPACE  2
*** 
*         IMPLIED DO LOOP PROCESSING
* 
*         THIS CODE ATTEMPTS TO COLLAPSE STATEMENTS OF THE FORM...
*         (((V(I,J,K),I=I1,I2,I3),J=J1,J2,J3),K=K1,K2,K3) 
*         THIS CODE DOES NOT COLLAPSE STATEMENTS WHICH CONTAIN... 
*         INDICES WHICH ARE EXPRESSIONS OR  CONSTANT INDEX  IN INDEX1 
* 
*         SUBSCRIPTS AND THEIR INDICES ARE STORED IN THE INDX TABLE 
* 
*                                             ?  ?  ?  =  SUBSCRIPTS
*                                  A(I,J,K),I=I1,I2,I3),J=... 
* 
*                                           ?           ?  = INDICES
*                                  A(I,J,K),I=I1,I2,I3),J=... 
* 
*         SPECIFIED DIMENSIONS ARE STORED IN THE NAMDEX TABLE 
* 
*                                    ? ? ?  =  SPECIFIED DIMENSIONS 
*                                  A(I,J,K),I=I1,I2,I3),J=... 
* 
 EL.(     MICRO  1,,/B3/           FROM TEST AT IOL.L 
 IOL.C    SB6    B0 
          SB1    2
          SB4    B0                B4 = 0 
  
*                                  012
*                                  ???
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
*                                  DETERMINE THE POSSIBLE COLLAPSE LEVEL
 IOL.CP   NEXTE 
          NE     B2,"EL.(",IOL.CA 
          SB4    B4+B5             B4  =  ( COUNT 
          NE     B4,B1,IOL.CP 
          NEXTE 
  
*                                     ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
 IOL.CA   NE     B2,B5,IOL.D       NOT A NAME 
          SX7    B4                ( COUNT TO COLLAPS 
          SA7    COLLAPS           SAVE THE PAREN CNT 
          SA5    NOCAL             FETCH FORMER STATEMENT NO. 
          SA2    CDCNT             CURRENT STMT NUMBER
          SX7    A4                SAVE ARRAY ADDRESS 
          BX3    X7                ARYADD IN X3 
          LX3    18 
          BX2    X2+X3             CARDCNT + ARYADD 
          MX0    1
          BX6    -X0*X5 
          BX0    X6-X2
          NZ     X0,IOL.CAZ 
          NG     X5,IOL.D 
          EQ     COLAPR8
*         ZERO OUT STORAGE AND INITIALIZE VARIABLES 
 IOL.CAZ  BSS    0
          SA2    COLLAPS           PAREN COUNT
          SA7    ARYADD 
          MX7    0
          BX6    X7 
          SA7    NAMDEX            I = 0
          SA6    A7+B5             J = 0
          SA7    A6+B5             K= 0 
          SB1    3                 B1 = 3 
          SA6    COLAPL 
          SA7    TEMPB       COUNT OF UN-INDEXED DIMENSIONS 
          SA6    TENCOL 
          SA7    INDX+B1           I3 = 0 
          SA6    A7+B5             J  = 0 
          SA7    A6+B1             J3 = 0 
          SA6    A7+B5             K  = 0 
          SA7    A6+B1             K3 = 0 
          SA7    MACOPC 
          BX6    X1                SAVE ARRAY NAME
          SA6    ARNAM
          NEXTE 
          IF.NE  EL.(,NOCOLAP      NOT AN ARRAY REFERENCE 
          BX1    X6                RESTORE ARRAY NAME FOR SYMBOL CALL(X1
          RJ     RSSW              SHUT DOWN SYMBOL TABLE 
          SYMBOL
          EQ     IOL.NF            NOT FOUND EXIT 
  
*                                  COLLECT ARRAY INFO...DIMENSION,TYPE
          RJ     KSSW              RESTORE SYMBOL TABLE CODE
          LX1    59-P.DIM 
          SB6    ARTH136
          PL     X1,NOCOLAP        IF A FUNCTION
          LX1    P.DIM+1
          RJ     EQUIVP      FIND (EQUIVED) BASE OF ARRAY 
          SA6    COLAP
          SA2    A2 
          MX0    L.TYP
          BX3    X0*X2
          LX3    L.TYP
          SX6    X3+B5
          SA6    MACLK4            K4 = TYPE + 1
          MX0    -L.DIMP
          AX2    P.DIMP 
          SA3    DIM1 
          BX5    -X0*X2 
          LX5    1                 INDEX TO DIM TBL 
          SB7    X5+B5
          SA5    X3+B7             WORD TWO OF THE DIM ENTRY
          MX0    60-3 
          SB1    3
          LX6    B1,X5
          BX2    -X0*X6 
          SB4    X2              B4 = NUMBER OF ARRAY DIMENSIONS
          BX6    X5 
          SB7    B0 
          SA6    DIMWRD 
          SA6    DIMVAL 
          SX7    B4                SAVE NO. ARRAY DIMS FOR COLAPM2
          SA7    NODIMS 
          SA3    ARYADD            RESTORE A4 
          SA4    X3-1 
  
*         STORE THE INDICES + THEIR SUBSCRIPTS IN THE INDX TABLE
*         I,I1,I2,I3,J,J1,J2,J3,K,K1,K2,K3
*                                  B7 = 0 1 2 
*                                       ? ? ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
 IOL.CIN  NEXTE 
          BX7    X1 
          ZR     B2,IOL.CIW 
          NE     B2,B5,IOL.CS 
          SA7    NAMDEX+B7
 IOL.CIW  BSS    0
          NEXTE 
          SB7    B7+B5
*                                  B1  =  EL.COMMA...3
*                                        ? ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
          NE     B2,B1,IOL.CS 
          LT     B7,B4,IOL.CIN     LOOP INCREMENT < ARRAY DIMS
          SB6    ARTH195
  
*         ARRAY NAME ERROR EXIT - B6 = ERROR NUMBER 
  
 IOERR2   SA3    ARNAM             ARRAY NAME 
          PX4    B5,X3
          SB7    PH2RETN
          EQ     ERPRO
  
*         NOT FOUND PATH FROM SYMBOL CALL 
* 
 IOL.NF   RJ     KSSW              RESTORE SYMBOL TABLE CODE
          EQ     NOCOLAP           BECAUSE A FUNCTION REFERENCE 
  
*                                            ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
IOL.CS    IF.NE  EL.),NOCOLAP 
          SX6    B5                INITIALIZE MULTIPLY FACTOR TO 1
          MX0    0
          NZ     B7,IOL.CS1 
          SB6    ARTH157           A( ) 
          EQ     IOERR2 
  
 IOL.CS1  SX2    B1+B5             X2 = 4 
          SA6    MACLK1            INITIALIZE  MULTIPLY FACTOR
          SB7    INDX 
          SA5    COLLAPS
  
*                                  STORE THE INDICES + THEIR SUBSCRPTS
*                                             ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
 INDXST   NEXTE 
          IF.NE  EL.COMMA,NOCOLAP 
          NEXTE 
  
*                                              ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
          NE     B2,B5,NOCOLAP     NOT A NAME 
          BX7    X1 
          SA7    X0+B7             SAVE NAME IN INDX + X0 
          SX0    X0+B5
          NEXTE 
  
*                                               ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
          IF.NE  EL.=,NOCOLAP 
  
*                                                ?  ?  ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
          SB6    DO7
 INDXST0  NEXTE 
          BX7    X4                PICK UP ENTIRE ELIST WORD
          GT     B2,B5,IOERRX      NOT A NAME OR A CONSTANT 
          SA7    X0+B7
          SX0    X0+B5
  
*                                                  ?  ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
          NEXTE 
          NE     B2,B1,INDXST2     NOT A COMMA
          IX6    X0-X2             CURRENT LOOP INCREMENT - 4...MAX DIM 
          NG     X6,INDXST0 
          SB6    ARTH145
          EQ     IOERR2 
  
*                                                        ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
 INDXST2  SX6    X0-3 
          MI     X6,IOERRX         LIMIT OF DO INDEX MISSING
          IF.NE  EL.),IOERR 
          SX5    X5-1              DECREMENT PAREN CNT. 
          MX0    0
          SB7    X2+B7             INCREMENT TABLE INDX BY 4
          PL     X5,INDXST
          BX3    X3-X3
 IOL.CS2  SA2    X3+NAMDEX
          ZR     X2,COLAPR   IF CONSTANT SUBSCRIPT
          SX6    X3+B5
          PX2    B5,X2
          SA6    TEMP1       COUNT OF I-TH SUBSCRIPT PROCESSING 
          SX7    DO7
          SA7    DOVART      SAVE ERROR NUMBER
          BX6    X2          X2 = ELIST VARIABLE
          SA6    A7+B5       SAVE ELIST VARIABLE
          CALL   INTVAR      CHECK OUT SUBSCRIPT
* 
*         RETURN HERE IF ERROR
* 
          PL     B2,DOVAR15  IF ERROR(BUT NOT TYPE INTEGER ER) REPORT IT
* 
*         RETURN HERE IF NO ERROR 
* 
 +        RJ     EQUIVP      FIND BASE AND BIAS OF INDEX
          SA3    COLAP       TABLE OF ARRAY NAME AND PROCESSED INDICES
          SA5    TEMP1       COUNT OF ELEMENTS IN COLAP 
 CAI1     SX3    X3 
          BX0    X3-X6
          ZR     X0,NOCOLAP  IF CURRENT INDEX IS SAME AS ENTRY IN TABLE 
          SX5    X5-1 
          SA3    A3+B5
          NZ     X5,CAI1     IF MORE IN TABLE 
          SA3    A5 
          LX7    18 
          BX6    X7+X6
          SX0    X3-3 
          SA6    X3+COLAP    ADD SUBSCRIPT TO COLAP 
          MI     X0,IOL.CS2  IF NOT ALL SUBSCRIPT PROCESSED 
*         BEGIN COLLAPSE PROCESSING...
*         A(I,J,K),  I=I1,I2,I3),...ETC.
*           '        '
*         NAMDEX  -  INDX 
*         CHECK SPECIFIED DIMENSION(NAMDEX) AGAINST INDICES(INDX) 
 COLAPR   BSS    0
          MX7    0
          SA7    MACSYM 
          SA5    COLAPL            MAKE SURE THAT THE CONTROL VARIABLE
          SA2    NAMDEX+X5         IS PROPER. 
          ZR     X2,COLAPR9        END OF ROAD...SPECDIM A CONSTANT 
          SB6    B5+B5       B6 = 2 
          LX7    X5,B6
          SA3    INDX+X7     FETCH CORRESPND INDEX
          IX6    X2-X3       CAN NOT HANDLE DIM NOT EQUAL INDEX 
          NZ     X6,COLAPR9 
          PX2    B5,X2             ELIST FORM 
          SX7    DO7
          RJ     DOVAR             CHECK VARIABLE 
          SX7    B1                SAVE THE ORDINAL FOR A POSSIBLE LATER
          SA7    TEMP1             REFERENCE
          SX7    V.DEF
          BX6    X1+X7       SET DEFINED BIT FOR INDEX
          SA6    A2+B5
          SB1    3
          SA5    COLAPL      REFORM A3 AFTER IT BEING DESTORYED 
          SB6    B5+B5       A3 CONTAINS THE ADDRESS OF INDEX 
          LX7    X5,B6       OF IMPLIED DO LOOP 
          SA3    INDX+X7
*                                  PROCESS SUBSCRIPT INCREMENT...I3 
*                                                      ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
*                                  I3 HAS TO BE A 1 OR NOT SPECIFIED
          SA1    A3+B1             CHECK I3 FOR 1 
          ZR     X1,COLAPR1        I3 NOT SPECIFIED 
          UX1    B2,X1
          NZ     B2,COLAPR9        I3 VARIABLE...NO COLLAPSE
          RJ     VALTYP 
          AX1    1
          NZ     X1,COLAPR9        I3 NOT = 1 
*                                  PROCESS SUBSCRIPT START...I1 
*                                                ?
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
*                                  MACOPC = 0...I1 = CONSTANT 
 COLAPR1  BSS    0
          SA1    TEMP1
          SB1    X1 
          RJ     DODEF             NOTIFY DO OF THE VARIABLE DEF
          SA2    =XRSELECT        IF NOT ACCUMULATING REFERENCES THEN GO
          ZR     X2,NOREFSA        TO 'NOREFSA'.
          SA1    TEMP1             OTHERWISE ADD A DEFINITION AND A 
          ADDREF X1,DEF            REFERENCE (SINCE THE CONTROL VARIABLE
          SA1    TEMP1             OCCURS TWO PLACES) 
          ADDREF X1,REF 
 NOREFSA  BSS    0
          SA5    COLAPL 
          LX5    2
          SX6    X5+B5
          SA2    INDX+X6           FETCH I1 
          UX1    B2,X2
          NZ     B2,COLAPRC        I1 NOT CONSTANT
          RJ     VALTYP            RETURNS CONSTANT IN X1 
          BX7    X1 
          SA7    MACLK3            STORE I1 IN MACRO BUFFER 
          AX1    1
          ZR     X1,COLAPR2        I1 = 1...FULL COLLAPSE POSSIBLE
          MX7    59 
          SA7    TENCOL            SET NO FURTHER COLLAPSE FLAG 
          EQ     COLAPR2
  
 COLAPRC  MX6    59 
          SA6    TENCOL 
          SX7    B5+B5
          SA3    MACOPC 
          SX1    X3-5 
          ZR     X1,COLAPRC1       IF VARDIM
          SA7    A3                MACOPC = 2 ... I1 = VARIABLE 
* 
 COLAPRC1 SX7    DO7
          RJ     DOVAR
          RJ     EQUIVP            STORE EQUIV BIAS(MACLK2),BASE(MACLS2)
          SA6    MACLS2      BASE OF I1 
          SA7    MACLK2      BIAS OF I1 
          SX7    B5 
          SA7    MACSYM      COUNT OF VARIABLE PARAMS 
  
*                                  PROCESS SUBSCRIPT LIMIT...I2 
*                                                   ? 
*                                  (((A(I,J,K),I=I1,I2,I3),...) 
 COLAPR2  BSS    0
          SA2    DIMWRD 
          SA5    COLAPL 
          BX6    X2 
          SA3    DIMVAL 
          AX6    18                SET  THE DIM WRD FOR NEXT TIME 
          SB6    3+X5 
          SA6    A2                DIMWRD 
          LX7    X3,B6
          SB1    2
          LX5    2
          SX4    X5+B1
          SA1    X4+INDX           PICK UP I2 
          SX6    X2                SAVE DIM CONSTANT VALUE
          SA6    TEMP 
          NG     X7,COLAPRV        ARRAY IS VARIABLY DIMENSIONED
          UX1    B2,X1
          NZ     B2,COLAPR4        I2 IS VARIABLE 
 COLAPR3  BSS    0
          RJ     VALTYP            RETURNS CONSTANT IN X1 
          SA3    MACLK1 
          SA2    COLAPL 
          LX2    2
          SA2    X2+INDX+1         FETCH I1 
          UX7    X2,B2
          ZR     B2,COLAPRS 
          SX7    X1+B5
          SA7    MACLK3 
          EQ     COLAPR8
*                                  PROCESS CONSTANT,CONSTANT CASE 
*                                  I = 1,05)
 COLAPRS  BSS    0
          SA5    MACLK3            I1 
          IX6    X1-X5             I2 - I1
          SX7    X6+B5             (I2 - I1) + 1
          PX6    X7,B0
          PX4    X3,B0
          DX6    X6*X4            ((I2 - I1)  + 1)  * PREVIOUS CALCULTN 
          SX7    X6 
          ZR     X7,COLAPRS1       IF WORD COUNT IS 0 OR - SET TO 
          PL     X7,COLAPRS2       A VALUE OF 1 FOR SINGLE ARRAYS AND 
 COLAPRS1 SX7    B5                ITEM COUNT = 1 
 COLAPRS2 BSS    0
          SA7    A3                RESULT TO MACLK1 FOR NEXT TIME THRU
          MX7    0
          SA7    MACLK3 
*                                       ?                    ?
*                                  A(10,10,10) - A(...),J=J1,05,J3)...
          SA2    TEMP              RETRIEVE DIM VALUE 
          IX6    X2-X1             CORRESPND ARRY DIM  -  CURRENT LIMIT 
          ZR     X6,COLAPR8        STILL COLLAPSABLE
          MX7    59 
          SA7    TENCOL 
          PL     X6,COLAPR8        CURRENT SPEC WITHIN DEFINED BOUNDS 
          SB6    -LISTIOC          REQUESTED DIM GREATER THAN DEFINED 
          SB7    COLAPR8
          EQ     ERPROI 
  
*                                  PROCESS I2 VARIABLE, I1 CONSTANT 
*                                  I = 1,LL)
 COLAPR4  BSS    0
          SA2    MACOPC            UPDATE PROSPECTIVE MACRO NUMBER
          NZ     X2,COLAPT
          SA3    MACLK3 
          SX7    X3-1 
          SA7    A3 
          SA3    TENCOL 
          NZ     X3,COLAPT
          SX2    X2+3              SET MACOPC FOR SPECIAL CASE...C*V
 COLAPT   BSS    0
          SX6    X2-5 
          SX7    X2+B5             MACOPC + 1 ...I1S VALUE + 1
          PX2    B5,X1       ELIST OF I2
          ZR     X6,COLAPRW  IF VARDIM
          SA7    A2 
          EQ     COLAPRW
          SPACE  2
 COLAPRV  SX7    5
          SA7    MACOPC 
          SA2    TEMP              FETCH DIM VALUE
          LX2    1
          SA5    SYM1              PROCESS VARIABLE DIM 
          IX3    X5-X2             SYM1 - ORDINAL 
          SA5    X3                PICK UP SYMBOL NAME
          AX5    P.NAME 
          UX7    B2,X1
          NZ     B2,COLAPR5        I2 IS A VARIABLE 
          BX6    X5                SIGN BIT CLEAR FOR SUBTRACTION AT
*                                  COLAPR3 WHEN TESTING FOR ARRAY BOUND 
          SA6    A2                STORE NEW VALUE FOR COLAPR3
          MX7    59 
          SA7    TENCOL 
          EQ     COLAPR3
 COLAPR5  BSS    0
          BX2    X1                I2 TO X2 FOR INTVAR
          UX1    B2,X1
          AX1    6                 SET UP FOR COMPARISON
          IX0    X5-X1             DIM SYMBOL - SPECIFIED SYMBOL
          ZR     X0,COLAPRU 
 COLAPRW  MX7    59 
          SA7    TENCOL            NO FARTHER COLLAPSE POSSIBLE 
  
 COLAPRU  SX7    DO7
          RJ     DOVAR
          SX7    B1               SAVE ORDINAL FOR POSSIBLE LATER REF 
          SA7    TEMP1
          RJ     EQUIVP            STORE EQUIV BIAS(MACLK2),BASE(MACLS2)
          SA3    MACSYM 
          SA6    X3+MACLS2   BASE OF I2 
          SA7    X3+MACLK2   BIAS OF I2 
          SX6    X3+B5       UPDATE COUNT OF VARIABLE PARAMS
          SA6    A3 
          SA1    =XRSELECT         IF NOT COLLECTING REFERENCES GO TO 
          ZR     X1,COLAPR8        'COLAPR8'. 
          SA1    TEMP1            OTHERWISE ADD A REFERENCE.
          ADDREF X1,REF 
  
*         TRY AND COLLAPSE REMAINING LEVELS...IF ANY
*         CHECK CURRENT COLLAPSE EFFORT AGAINST MAX COLLAPSABLE EFFORT
  
 COLAPR8  SA1    CDCNT             CURRENT STMT NUMBER
          SA2    ARYADD 
          LX2    18 
          BX7    X1+X2
          SA7    NOCAL
          SA3    TENCOL 
          SA5    COLAPL 
          SA2    COLLAPS
          IX7    X2-X5             TOTAL COLLAPSE LEVEL - CURRENT LEVEL 
          ZR     X7,COLAPC         READY TO ISSUE THE MACROS
          NG     X3,COLPD          IF NO FURTHER COLLAPSE 
  
*         CIRCULATE PARENTHESIS LEVELS UNTIL COLLAPSABLE LEVEL CURRENT
          SX6    X5+1              UPDATE THE CURRENT COLLAPSE LEVEL
          SA6    COLAPL 
          EQ     COLAPR 
 COLPD    MX4    59                NON-FULL COLLAPSE FLAG 
          RJ     CKINDX            CHECK FOR LEGAL DO INDICES 
          EQ     IOL.D             PROCESS NON-COLLAPSIBLE DO 
  
  
 COLAPR9  BSS    0                 CANNOT COLLAPSE THIS LEVEL...
          SA5    COLAPL 
          ZR     X5,NOCOLAP        THIS LEVEL = LEVEL 1 
          MX7    59 
          SA7    TENCOL            SET NO FARTHER COLLAPSE FLAG 
          SX6    X5-1              DECREMENT COLLAPSE LEVEL...
          SA6    A5 
          EQ     COLAPR8           CHECK FOR TIME TO ISSUE MACROS 
  
  
*** 
*         CALL IXFN FOR THE ADDRESS REFERENCE AND CONSTRUCT THE CORRECT 
*         MACRO.  TWO DISTINCT ARRAY REFERENCES EXIST IN THIS CODE... 
*         THE FIRST IS THE ORIGINAL REFERENCE PASSED BY SCANNER.
*         THE SECOND IS CONSTRUCTED BY THE CODE USING STORAGE BEGINNING 
*         AT I2 IN THE INDX TABLE AND PROCEEDING THROUGH THE NAMDEX TAB.
*         THE CONSTRUCTED REFERENCE IS A HYBRID OF THE ORIGINAL INDICES 
*         AND THEIR SUBSCRIPTS DEPENDING UPON THE COLLAPSABILITY. 
  
*         B6,B7 COUNTING SCHEMA... 123 4567 8 901 
*                                  ??? ???? ? ??? 
*                                  A(I2+1,J2,K2), 
  
*         FIRST CHECK TO DETERMINE WHETHER A RESTART CALL IS NEEDED 
*         IN CASE ONE OF THE INDICES WAS ALSO DEFINED IN THE SAME 
*         STATEMENT IF IT WERE AN INPUT STATEMENT.
  
 COLAPC   SA3    IOFLAG 
          ZR     X3,COLAPM         IF NOT AN INPUT STATEMENT
          SA4    PARCNT 
          ZR     X4,COLAPM         IF NOTHING TO OUTPUT 
          SA1    L.IOLST
          ZR     X1,COLAPM         IF NOTHING IN ORDINAL TABLE
 COLAPC4  SA2    NODIMS      NO. OF DIMS SPECIFIED
          SX5    X5+B5       NO. OF DIMS PROCESSED
          IX3    X2-X5
          ZR     X3,COLAPC5  IF ALL SUBSCRIPTS PROCESSED
          SA2    X5+NAMDEX   FIRST UNPROCESSED SUBSCRIPT LEFT 
          ZR     X2,COLAPC5  IF A CONSTANT
          SA3    TEMPB
          SA2    X5+COLAP+1 
          SX6    X2 
          AX2    18 
          SX7    X2 
          SA6    X3+TEMPBA   BASE OF UNPROCESSED SUBSCRIPT
          SA7    X3+TEMPBI   BIAS OF UNPROCESSED SUBSCRIPT
          SX6    X3+B5
          SA6    A3 
          EQ     COLAPC4
  
 COLAPC5  BSS    0
          SA4    MACSYM 
          SB6    X1                TABLE LENGTH 
          SA3    O.IOLST           TABLE ORIGIN 
          SA5    TEMPB
          SB3    X3          FWA OF TABLE 
          MX3    -AP.IHL
          NZ     X5,COLAPC7  IF THERE ARE SUBSCRIPTS W/O INDICES
 COLAPC6  ZR     X4,COLAPM   IF NO INDICES TO CHECK FOR RESTART CALLS 
          SB4    X4 
          MX4    0           CLEAR FLAG FOR EXIT
          SA1    MACLS2            FIRST INDEX BASE 
          SA5    MACLK2            FIRST INDEX BIAS 
  
 COLAPC1  SA2    B3          FIRST TABLE ENTRY
          SB2    B6                INITIALIZE COUNTER 
  
 COLAPC2  BX6    -X3*X2 
          IX0    X6-X1
          NZ     X0,COLAPC8  IF IH DO NOT MATCH 
          LX2    59-AP.CRP
          MI     X2,COLAPC3  CLASS REF, FORCE RESTART 
          LX2    AP.CRP+1-AP.CAP
          BX6    -X3*X2 
          IX0    X6-X5
          ZR     X0,COLAPC3  IF IH,CA MATCH, FORCE RESTART
  
 COLAPC8  SA2    A2+B5       NEXT TABLE ENTRY 
          SB2    B2-B5             DECREMENT ITEM COUNT 
          NZ     B2,COLAPC2        IF LIST NOT EXHAUSTED
          SB4    B4-B5             DECREMENT INDEX COUNT
          ZR     B4,COLAPC6  IF ALL INDICES EXHAUSTED 
          SA1    A1+B5             NEXT INDEX BASE
          SA5    A5+B5             NEXT INDEX BIAS
          EQ     COLAPC1
  
 COLAPC7  SA1    TEMPBA      BASE OF SUBSCRIPT
          SB4    X5          NUMBER OF SUBSCRIPTS W/O INDICES 
          SA5    TEMPBI      BIAS OF SUBSCRIPT
          EQ     COLAPC1
  
 COLAPC3  RJ     IARC              ISSUE RESTART CODE 
          MX7    0
          SA7    L.IOLST           CLEAR LIST LENGTH
  
 COLAPM   BX4    X4-X4             FULL COLLAPSE FLAG 
          RJ     CKINDX 
          SB3    3
          SA2    NODIMS 
          SB1    X2                B1 = NUMBER OF DEFINED ARRAY DIMS
          SA1    MACOPC 
          SB4    B5+B3             B4 = 4 
          SB7    B5                  B7 = 1 
          SB6    B3-B5             B6 = 2 
          SX6    M.IOLWC
          IX7    X6+X1             IOLP1C + MACOPC
          SA7    MACOP
          SA2    COLAPL 
          SX0    B4+B5             X0 = 5 
          IX6    X0-X1             5 - MACRO NO.(0...5) 
          ZR     X6,COLAPM2 
          SA5    NRLN 
          BX7    X5 
          SA7    MACLP1            RESULT NUMBER
          SA7    TEMPA
          SX6    X5+B5             INCREMENT NRLN 
          SA6    A5 
          EQ     COLAPM8           GO TO 'COLAPM8' TO FINISH UP.
 COLAPM2  BSS    0                 PROCESS THE DOUBLE IXFN CALL (VARDIM)
          SA3    ARYADD 
          SA2    INDX+1            FETCH I1 TO PRESERVE FROM CLOBBERING 
          BX7    X2 
          SA3    X3                FETCH THE ARRAY ELIST NAME 
          SA7    TEMP              SAVE I1
          SA5    A2+B5             I2 
          BX7    X3 
          SA7    A2+B6
          SX6    A2+B6
          SA6    SELIST 
          SA1    A3-B5             FETCH (
          BX6    X1 
          SA6    A7-B5
          BX7    X5                INDX + 2 
          SA7    A6-B5             A(I2 
          SA3    PLUS 
          BX6    X3 
          SA6    A7-B5             A(I2+
          SA3    CON1 
          BX7    X3 
          SA7    A6-B5             A(I2+1 
          SA1    A1-B6             FETCH THE COMMA
          BX7    X1 
          SA7    A7-B5             A(I2+1,
*         CHECK NOW FOR THE CORRECT NO. OF SUBSCRIPTS TO REPLACE
          SA2    COLAPL 
          SB1    B1+B3
          ZR     X2,COLAPM5 
 COLAPM4  BSS    0
          AX2    1                                 ?
          SA4    A5+B4             I,I1,I2,I3,J,J1,J2,J3,K,K1,K2,K3 
          BX6    X4 
          SB4    B4+B4             B4  =  8 
          SA6    A7-B5             J1  _  J PLACE OF THE ARRAY REF
          SA1    A1-B6             SKIP THE NEXT INDEX AND GET , OR ) 
          BX7    X1 
          SA7    A6-B5             A(I2+1,J2, 
          SB7    B7+B5
          NZ     X2,COLAPM4 
 COLAPM5  BSS    0
          SA1    A1-B5
          BX7    X1 
          SA7    A7-B5
          SB7    B7+B5
          NE     B7,B1,COLAPM5     B7 NOT EQUAL TO DEFINED NO. ARRY DIMS
  
          SA5    NRLN 
          BX7    X5 
          SX6    X5+B5
          SA7    MACLP1            RESULT NUMBER
          SA6    A5 
          SA7    TEMPA
          MX6    1
          SX3    B5                NO EXPRESSION FLAG 
          SA6    SAVDAN      FORCE CODE FLUSHING BY ARITH 
          IXFN   NOREF
          MP=    P3,X6
          SA2    TEMP              PICK UP STORED I1 AND PUT
          BX6    X2                IT BACK WHERE IT BELONGS AT I1 
          SA3    MACLK4            TYPE+1 OF ARRAY
          SX4    B5 
          SX0    X3-T.DBL-1  UNBIAS TYPE VALUE
          AX0    59 
          BX5    X0*X4             0 IF DBL OR CPLX, 1 IF SINGLE
          SX7    X5+23
          SA6    INDX+1 
          SA7    MACLK1            23 IF DBL OR CPLX, 24 IF SINGLE
          SA2    COLAPL 
          SB6    B5+B5
          SB4    B6+B6           B4 = 4 
          SX6    B5 
          SA6    BIO         MARK NO RESTART CALL FOR THIS IXFN 
 COLAPM8  RJ     ARYCONS
          MX6    1
          SX3    B5                NO EXPRESSION FLAG 
          SA6    SAVDAN            TO FORCE CODE FLUSHING BY ARITH
          SA6    CRFLAG      ARRAY REF IS A CLASS REF 
          IXFN   IOFLAG 
          SA5    MACOP
          SX4    X5-M.IOLWC 
          ZR     X4,COLAPAL        SEE IF ALL LEVELS COLLAPSABLE
 COLAPM9  BX7    X2 
          SA7    TEMP              SAVE WORD B OF ENTRY 
          MP=    P2,X6
          RJ     MACOUT            ISSUE COLLAPSE MACRO 
  
          SA7    MACBUF-1          INITIALIZE A7 FOR STORES 
          SA2    TEMP              RESTORE WORD B 
          SA3    TEMPA
          SB4    B0                WORD COUNT FOR WRITE CALL
          BX6    X3                RESULT NUMBER OF LAST MACRO
          RJ     PSTAPL            GENERATE STORE TO APLIST MACROS
          RJ     STIOM             ISSUE -1 APLIST MACRO WORD 
  
  
 COLAPMW  BSS    0                 RESTORE THE CORRECT SELIST AND MOVE _
          SA5    SAVELIS
          SX6    X5 
          SA6    SELIST            UPDATE ELIST POINTER 
          BX7    X7-X7
          SA7    NOCAL           CLEAR REPROCESS FLAG 
          EQ     IOL.NE            PROCESS THE NEXT ELIST ITEM
 ARYCONS  SPACE  4,8
**        ARYCONS - CONSTRUCT AN ARRAY REFERENCE FOR THE IXFN, USING
*         THE E-LIST ARRAY REFERENCE GENERATED BY *SCANNER*.  THIS REF
*         WILL REPLACE THE ORIGINAL.
  
 ARYCONS  ENTRY. *                 ** ENTRY/EXIT ** 
          SA3    ARYADD 
          SB3    B0 
          SB1    X2+B6             COLAPL + 2 
          SB7    EL.) 
          SA4    X3-2 
 ARYCON1  UX1    B2,X4
          SA4    A4-B5             UPDATE ELIST ADDRESS POINTER 
          NE     B2,B7,ARYCON1     CURRENT ELEMENT NOT EQ ) 
          SB3    B3+B5             INCREMENT RIGHT PAREN COUNT
          NE     B3,B1,ARYCON1     CURRENT PAREN NOT EQ COLLAPSE PAREN
          SX6    A4 
          SA6    SAVELIS
          SA5    INDX+B5           I1 
          BX7    X5 
          SA7    X3-2              A(I1 
          BX6    X3                SET UP SELIST FOR IXFN 
          SA6    SELIST 
          ZR     X2,ARYCONS        NO MORE COLLAPSABLE SUBSCRIPTS 
  
*         THIS ROUTINE REPLACES THE INDICES THAT ARE COLLAPSABLE WITH 
*         THEIR RESPECTIVE STARTING SUBSCRIPTS... 
  
*                                    ?<<<<<<<<? 
*                                  A(I,J,K),I=I1,I2,I3),J=J1,J2(J3),... 
  
 ARYCON0  BSS    0
          AX2    1                              ? 
          SA4    A5+B4             I,I1,I2,I3,J,J1,J2,J3,K,K1,K2,K3 
          BX6    X4 
          SB4    B4+B4             B4 = 8 
          SA6    A7-B6             J1 _  J
          SB6    B6+B6
          NZ     X2,ARYCON0        ALL THE LEVELS ARE COLLAPSABLE 
          EQ     ARYCONS
  
  
*         GENERATE APLIST ITEM WORD WHEN ALL LOOP LEVELS ARE COLLAPSABLE
  
 COLAPAL  SA5    APLRST 
          AX5    1
          ZR     X5,COLAPM9        IF IXFN MACRO WAS OUTPUTTED LAST 
          SA4    MACLK1 
          BX6    X4 
          BX7    X0-X0
          SA6    ITEMCT            SET UP ITEM COUNT
          SA7    A5                CLEAR FLAG 
          RJ     LSTITM            ISSUE APLIST WORD
          EQ     COLAPMW
  
  
*         NOCOLAP - FAIL EXIT 
  
 NOCOLAP  SA5    CDCNT             CURRENT STATEMENT NUMBER 
          MX0    1
          SA3    ARYADD 
          LX3    18 
          BX6    X0+X5             NO COLLAPSE = -
          BX7    X6+X3             NOCAL = -...ARYADD,CARDCNT 
          SA7    NOCAL             STORE ARRAY ADDRESS FOR FUTURE TEST
          EQ     IOL.D             EXIT TO STANDARD DO LOOP PROCESSING
 CKINDX   SPACE  3,6
**        CKINDX - CHECK THE INDICES OF A NEST OF I/O LOOPS FOR 
*         REDEFINITION OF DO VARIABLES OF OUTER LOOPS.
*         ENTRY  (X4) = - IF NON FULL COLLAPSE CALL 
*                       + IF FULL COLLAPSE ENTRY
  
 CKINDX   ENTRY. *                 ** ENTRY/EXIT ** 
          SA3    COLLAPS
          ZR     X3,CKINDX         IF ONLY ONE LEVEL
  
          LX3    2                 4 * NO. OF PAREN LEVELS
          SB3    X3+INDX+4         UPPER LIMIT FOR SCAN 
          SA5    INDX              CONTROL VARIABLE I 
          RJ     DOINDX            CHECK FOR REDEFINITION 
  
          SA2    COLAPL 
          AX2    1
          ZR     X2,CKINDX         IF ONLY ONE LEVEL COLLAPSED
          SA5    INDX+4            CONTROL VARIABLE J 
          RJ     DOINDX            CHECK FOR REDEFINITION 
          EQ     CKINDX 
 DOINDX   SPACE  4,8
 DOINDX   ENTRY. *                 ** ENTRY/EXIT ** 
          SB6    A5+4              STARTING INDEX ADDRESS 
          MX0    12 
 DOI1     GE     B6,B3,DOINDX      IF THE SCAN IS DONE
          SA3    B6                INDX ENTRY 
          BX6    -X0*X3 
          BX7    X6-X5
          SB6    B6+B5
          NZ     X7,DOI1           IF INDEX ENTRY .NE. CONTROL VAR
  
          SB2    A3 
          SB6    E.DO13            ERROR MESSAGE NO.
          BX3    X5 
          SB1    INDX+8            CONTROL VAR K
          SB7    DOINDX            RETURN ADDRESS 
          NG     X4,DOINDX         IF NOT FULL COLLAPSE, EXIT 
 DOI2     BX4    X4-X4
          EQ     B2,B1,ERPRO       IF A CONTROL VARIABLE
          SB1    INDX+4 
          EQ     B2,B1,ERPRO       IF A CONTROL VARIABLE REDEF
          EQ     ERPROI            ONLY A LOOP LIMIT REDEF
  
          SPACE  3
*** 
*         VALTYP - CHECK CONSTANT TYPE AND RETURN VALUE 
* 
*         ON ENTRY: 
*                X1 = LOWER 48 BITS OF ELIST FOR CONSTANT 
* 
*         ON EXIT:  
*                X1 = VALUE 
* 
 VALTYP1  SB1    -B5               CONVERT ONLY 
          BX1    X4 
          CALL   CONVERT
  
 VALTYP   ENTRY. *                 ** ENTRY/EXIT ** 
          PX4    X1 
          SX0    134B 
          AX1    45 
          SB7    X1+59-6
          LX6    B7,X0
          PL     X6,VALTYP1        IF INTEGER,OCTAL OR HOLERITH 
  
          SB6    DO7               BAD DO LIMIT 
          EQ     IOERRX 
          SPACE  3
*** 
*         DOVAR - CALL INTVAR IN DOPROC TO CHECK FOR PROPER DO VARIABLE 
* 
*         ON ENTRY: 
*                X2 = ELIST FOR VARIABLE
*                X7 = ERROR NUMBER
* 
  
 DOVAR1   BX6    X2 
          SA6    A7+B5             AND VARIABLE 
          CALL   INTVAR 
 DOVAR15  SA5    DOVART 
          EQ     DOVAR2 
  
 DOVAR    ENTRY. *                 ** ENTRY/EXIT ** 
          SA7    DOVART            SAVE ERROR NUMBER
          EQ     DOVAR1 
  
 DOVAR2   SA4    A5+B5             VARIABLE 
          SB6    X5 
          EQ     IOERRX 
  
 DOVART   BSS    2                 2 TEMPORARIES FOR DOVAR
          SPACE  3
**        EQUIVP - RETURN BASE/BIAS OF SYMBOL 
*         ENTRY  X1 = WORD A OF SYMBOL
*                A2 _ WORD B OF SYMBOL
*                B1 = SYMTAB ORDINAL
*         EXIT   X6 = BASE
*                X7 = BIAS
*         SAVE   A2 
 EQUIVP   ENTRY. *                 ** ENTRY/EXIT ** 
          LX1    59-P.EQU 
          SX6    B1                SYMTAB ORDINAL 
          SX7    B0 
          PL     X1,EQUIVP   IF NOT EQUIVALENCED
          SA2    A2          WORD B 
          MX0    -L.DIMP
          LX2    -P.DIMP
          SA1    DIM1 
          BX6    -X0*X2 
          SB2    X1 
          LX6    1           2*ORD(DIM) 
          SA3    X6+B2       WORD 1 OF DIMTAB ENTRY 
          AX3    18 
          SX7    X3                BIAS 
          AX3    18 
          SX6    X3                BASE 
          EQ     EQUIVP 
  
  
*         FIRST OCCURANCE OF NAME AS ARRAY IN IMPLIED DO LOOP 
  
 IOERR1   BX2    X0+X2             SET VAR BIT
          IX7    X6+X2             AND TYPE 
          SA7    A2 
          SB6    ARTH136
          EQ     CFSIV1            GO ISSUE ERROR MESSAGE 
          TITLE              IMPLIED DO PROCESSING - NO COLLAPSE CASE 
*** 
*         IMPLIED DO PROCESSING - WHERE LIST IS NOT COLLAPSABLE 
* 
  
 IOL.D    ADVIN 
          BI=    B4,EL.)
          BI=    B3,EL.(
          BI=    B6,EL.=
          BI=    B7,EL.EOS
          SB1    B0                B1 = ADDRESS OF = SIGN AT LEVEL 0
          MX0    0                 PAREN COUNT
          SB2    EL.S)
          PX7    B2,X0             X7 = ELIST FOR SPECIAL PAREN 
          SX2    B5 
  
*         SCAN FOR = SIGN AT LEVEL 0 AND ) AT LEVEL -1
  
 IMDS     NEXTE 
          LE     B2,B5,IMDS        IGNORE CONSTANTS AND NAMES 
          NE     B2,"EL.(",IMDS1
          IX0    X0+X2             INCREMENT PAREN COUNT
          EQ     IMDS 
  
 IMDS1    NE     B2,"EL.=",IMDS2
          SA4    A4+2        TRY TO LOCATE LEFT PARENTHESIS 
          UX1    B2,X4       IN ORDER TO DETECT IMPLIED DO SPEC 
          NE     B2,"EL.(",IMDS1A  ERROR, IF NOT LEFT PARENTHESIS 
          SB6    -E.PIL 
          EQ     IOERRX      IO SYNTAX ERROR OCCURS 
IMDS1A    SA4    A4-2        BACKUP TOKE LIST 
          NZ     X0,IMDS     IGNOR INNER LOOP 
          NZ     B1,IOERR          IF MORE THAN ONE OUTERMOST LOOP
          SB1    A4                SAVE ADDRESS 
          EQ     IMDS 
  
 IMDS2    EQ     B2,"EL.)",IMDS3
          NE     B2,"EL.EOS",IMDS 
          EQ     IOERR
  
 IMDS3    IX0    X0-X2             DECREMENT PAREN COUNT
          PL     X0,IMDS           IF NOT OUTER MOST
          ZR     B1,IMDS4          IF NO = SIGN FOUND 
          SA7    A4                STORE SPECIAL PAREN
          EQ     DOBEGIN
  
 IMDS4    NEXTE                    ELEMENT AFTER ZERO LEVEL PAREN 
          LE     B2,"EL.(",IMDS5   NOT FOLLOWED BY AN OPERATOR
          SB1    EL.S)
          EQ     B2,B1,IMDS5       IF FOLLOWED BY SPECIAL PAREN 
          BACKE                    BACK OVER THE OPENING PAREN
          EQ     IOL.N
  
 IMDS5    LX6    18 
          SX3    A4+B5       ADDRESS OF ELIST FOR ) 
          BX7    X6+X3
          SA4    X5          ELIST FOR (
          SA7    CPLXC       24/0,18/SELIST,18/EPOINT FOR ) 
          CALL   CFCD        CHECK FOR COMPLEX DATA 
          SA5    CPLXC
          ZR     X0,IMDS5A   IF CPLX CONST
          MX7    0
          SB2    EL.S)
          PX6    B2,X7
          SA7    A5 
          SA6    X5          STORE SPECIAL PAREN
          EQ     IOL.L
  
 IMDS5A   BX6    X1 
          LX7    X2 
          SA6    =XCONST     REAL PART
          SA7    A6+1        IMAGINARY PART 
          SA3    SELIST 
          AX5    18 
          BX7    X5 
          LX6    X3 
          SA7    A3          RESTORE ELIST POINTER
          SA6    A5          FLAG CPLX CONST
          EQ     IOL.L
  
*         DONEX - RETURN FROM DOPROC AFTER PROCESSING END OF LOOP 
  
 DONEX    GETE                     GET FIRST E-LIST ELEMENT 
          BI=    B3,EL.EOS
          SB4    EL.S)
  
 DONEX.L  NEXTE                    NEXT ELEMENT 
          EQ     B2,"EL.EOS",IOERR     IF WE HIT END OF STMT
          NE     B2,B4,DONEX.L     LOOP IF NOT A SPECIAL PAREN
  
          UPDATE                   UPDATE E-LIST POINTER
          EQ     IOL.NE            GO GET NEXT ELEMENT
  
  
*         ISSUE I/O CALL BEFORE GENERATION OF DO-BEGIN LOOP CODE
  
 DOBEGIN  SA4    PARCNT 
          ZR     X4,DOIT           IF NOTHING TO OUTPUT 
          SX6    B1 
          SA6    TEMP              SAVE INFORMATION FOR DOPROC
          RJ     ARIOCM            ISSUE RESTART CODE 
          SA1    TEMP 
          SB1    X1                RESTORE ELIST POINTER FOR DOPROC 
          SA4    IONAME 
          NG     X4,DOIT           IF NO ADJUSTMENTS NECESSARY
          SX5    GEFNT             MACRO HEADER ADDRESS 
          SX6    X4+B5             ADJUST ADDRESS OF OBJECT NAME
          LX5    18 
          MX0    1
          IX3    X5+X6
          BX7    X0+X3
          SA7    A4 
          EQ     DOIT              PROCESS LOOP 
  
  
*         ISSUE I/O CALL BEFORE GENERATION OF DO-END LOOP CODE
  
 DOEND    SA4    PARCNT 
          ZR     X4,DONE           IF NOTHING TO OUTPUT 
          RJ     ARIOCM            ISSUE RESTART CODE 
          EQ     DONE              GENERATE DO-END LOOP CODE
 ARIOCM   SPACE  4,8
**        ARIOCM - ISSUE I/O APLIST RESTART CALL MACRO. 
  
 ARIOCM   ENTRY. *                 ** ENTRY/EXIT ** 
          RJ     IIR         ISSUE IOLST TABLE TO RLIST IF OPT=2
          SB1    1
          WRITEC =XF.CMPS,EIOM.CD,2 
          SA2    DATA.
          SB5    1
          SX6    X2+B5
          SA6    A2                INCREMENT BLOCK SIZE 
          SA4    IONAME 
          SA1    X4                OBJECT ROUTINE NAME
          RJ     IOCM              ISSUE I/O CALL 
          RJ     IOSETUP           BEGIN NEW APLIST 
          EQ     ARIOCM 
  
  
 EIOM.CD  LIT    13C  EIO     -0B 
  
  
*         IARC - ISSUE INPUT APLIST RESTART CALL
  
 IARC     ENTRY.
          RJ     ARIOCM            ISSUE RESTART CODE 
          SA4    IONAME 
          NG     X4,IARC           IF NO ADJUSTMENT NECESSARY 
          SX5    GEFNT             MACRO HEADER ADDRESS 
          SX6    X4+B5             ADJUST ADDRESS OF OBJECT NAME
          LX5    18 
          MX0    1
          IX3    X5+X6
          BX7    X0+X3
          SA7    A4 
          EQ     IARC 
 PLI      TITLE  PLI - PROCESS LIST ITEMS 
**        PLI - PROCESS LIST ITEMS
* 
*         I/O LIST ITEMS IN INPUT STMTS ARE PUT IN THE IOLST TABLE TO 
*         CHECK FOR NECESSARY RESTART CALLS OR, IF IN OPT=2, ALL ITEMS
*         ARE PUT IN THE IOLST TABLE AND THEN THE TABLE ISSUED AS A 
*         RMACRO FOR OPTIMIZATION PURPOSES. 
* 
*         ENTRY  (X2) = SYMTAB ORD OF ITEM TO BE ADDED TO THE TABLE 
*                (B5) = 1 
* 
*         EXIT   (X2) = SYMTAB ORD OF ITEM
  
 PLI      ENTRY. *           ENTRY/EXIT 
          SA3    =XOPT2 
          NZ     X3,PLI1     IF OPT=2 
          SA4    PIOFLAG
          ZR     X4,PLI      IF NOT A LIST ITEM IN AN INPUT STMT
  
 PLI1     SA1    SYM1 
          BX6    X2 
          LX3    B5,X2
          SB3    X3+B5
          SA0    X1 
          SA3    A0-B3       WORDB
          LX3    59-P.LDO 
          MI     X3,PLI      IF LOAD ONLY    ( CON. , HOL. )
          SA1    IOEXP
          SA6    SYMORD      SAVE FOR RESTORE AT EXIT 
          NZ     X1,PLI8     IF RESULT OF EXPRESSION
  
          SA2    =XRL2TS     FIRST WORD OF LAST ARLIST
          SA1    X2+2        RMACRO HDR WORD
          MX0    -AP.IHL     SAME MASK IS USED FOR CA 
          SA5    CRFLAG      ENSURE A CLEARED CRFLAG
          MX7    0
          UX1    B2,X1
          SA3    A1+B5       IH IN HDR WORD + 1 
          SX4    B2+M.SXIT
          BX1    -X0*X3      IH IS EXTRACTED
          SA7    A5 
          LX1    AP.IHP 
          ZR     X4,PLI5     IF INDEX FUN RMACRO
  
*         IH IN HDR + 1, CA IN HDR + 3 GENERALLY
  
          SA4    A1+3        CA IN HDR WORD + 3 
          BX2    -X0*X4      CA IS EXTRACTED
          LX2    AP.CAP 
          BX1    X2+X1       CA,IH
          ZR     X5,PLI3     IF NOT SPECIAL CASE CLASS REF CHECK
          MI     X5,PLI6     IF ARRAY REF IS A CLASS REF
  
*         FOR VAR FORMAT, VAR NAME OF ENC/DEC, OR FWA OF BUFIO, NAME IS 
*         A CLASS REF IF AN ARRAY OR EQUIVED. 
  
          SB2    B3-B5
          SA2    A0-B2       WORD A 
          LX2    59-P.DIM 
          MI     X2,PLI6     IF DIMENSIONED, IS A CLASS REF 
          LX2    P.DIM-P.EQU
          MI     X2,PLI6     IF EQUIVED, IS A CLASS REF 
  
*         IF RF > 0, SET CLASS REF BIT
  
 PLI3     SA2    A1+2        RF IN HDR WORD + 2 
          MX5    -RM.RIL
          LX2    -RM.RIL
          BX3    -X5*X2      RF IS EXTRACTED
          SB2    X3 
          GE     B2,B5,PLI6  RF ON, SET CR BIT
  
*         SET P1 BIT IF DOUBLE WORD RESULT
  
 PLI4     SA5    TYPEFG 
          PL     X5,PLI7     IF NOT  DOUBLE WORD
          MX2    1
          LX2    1+AP.P1P 
          BX1    X2+X1       P1,CA,IH 
          EQ     PLI7 
  
*         IH, CA IN HDR + 1 FOR INDEX FUN RMACRO
  
 PLI5     LX3    -AP.IHL
          BX5    -X0*X3      CA IS EXTRACTED
          LX5    AP.CAP 
          BX1    X5+X1       CA,IH
  
*         SET CLASS REF BIT 
  
 PLI6     MX2    1
          LX2    1+AP.CRP 
          BX1    X2+X1       CR,CA,IH 
  
*         SET IO BIT IF INPUT 
  
 PLI7     SA2    PIOFLAG
          MI     X2,PLI8     IF ITEM USED 
          SA3    LDFLAG 
          MX5    1
          MI     X3,PLI7A    IF LIST-DIRECTED I/O 
          LX5    1+AP.IOP 
          SA3    VFFLAG 
          NZ     X3,PLI7A    SET USE/DEF BITS IF VAR FMT IO 
          BX1    X5+X1       IO,P1,CR,CA,IH 
          EQ     PLI8 
  
*         SET USE/DEF BITS IF LIST-DIRECTED INPUT 
  
 PLI7A    MX5    2
          LX5    2+AP.USEP
          BX1    X5+X1
  
 PLI8     ADDWD  IOLST,X1    ADD ENTRY TO TABLE 
  
          SA2    SYMORD      RESTORE SYMTAB ORD 
          EQ     PLI         EXIT 
  
 IIR      TITLE  ISSUE IOLST TO RLIST 
*         IIR - ISSUE IOLST TO RLIST
* 
*         WHEN IN OPT=2, ISSUE USE/DEF INFORMATION IN IOLST TO RLIST. 
* 
  
 IIRA     SA3    PIOBUF 
          SA4    O.IOLST
          BX6    X3 
          MX7    0
          SA6    X4-1        RESTORE WORD AT (O.IOLST) -1 
          SA7    L.IOLST     CLEAR LENGTH OF PARAMS FLAG
  
 IIR      ENTRY. *           ENTRY/EXIT 
          SA2    =XOPT2 
          ZR     X2,IIR      EXIT IF NOT OPT=2
          SA1    O.IOLST
          SA3    X1-1 
          BX6    X3 
          MX7    0
          SA6    PIOBUF      SAVE WORD AT (O.IOLST) -1
          SA7    TINDX       INITIALIZE INDEX TO TABLE
          SA4    L.IOLST
  
 IIR1     SA5    TINDX
          IX0    X4-X5       NO. OF  WORDS  IN IOLST
          ZR     X0,IIRA     IF TABLE EMPTY 
          SX2    PIOMAX 
          IX4    X0-X2       LEN = MIN(DIFF,MAX)
          PL     X4,IIR2     IF MORE WORDS IN TABLE THAN MAX
          BX2    X0 
  
 IIR2     IX6    X5+X2       INCREASE INDEX BY LEN
          SA3    O.IOLST
          SA6    A5 
          IX0    X3+X5       ADDR OF CURRENT FIRST ITEM 
          SB3    -PIO 
          LX2    R1.INP 
          PX7    B3,X2
          SA1    FMTORD      SYMTAB ORDINAL FOR FORMAT LABEL
          LX1    R1.SOP 
          BX7    X7+X1       INSERT FORMAT OR ZERO
          SB7    X0-1        ADDR OF HDR WORD 
          SA7    B7 
          MX6    0
          SA6    FMTORD      CLEAR FMTORD 
  
          WRM    B7          OUTPUT IO USE/DEF TABLE TO RLIST 
  
          SA4    L.IOLST
          EQ     IIR1        CHECK FOR MORE ITEMS 
  
 ONI      TITLE  ONI - OUTPUT NAMELIST ITEMS
**        ONI - OUTPUT NAMELIST ITEMS 
*         IF OPT=2 WHEN A NAMELIST GROUP NAME IS SPECIFIED AS THE FORMAT
*         THE NAMELIST VARIABLES ASSOCIATED WITH THAT GROUP NAME IS 
*         TRANSFERRED TO THE IOLST TABLE.  A CALL TO SUBROUTINE IIR 
*         WILL RESULT IN OUTPUT OF THE VARIABLES TO RLIST.
*         THE NAMELIST VARIABLES WILL HAVE BEEN SET UP IN THE NML TABLE 
*         BY THE NAMELIST PROCESSOR.
* 
*         ENTRY  (X2) = SYMTAB WORD B OF GROUP NAME 
*                (B1) = SYMTAB ORD OF GROUP NAME
*                (B5) = 1 
* 
*         EXIT   (B1) = SYMTAB ORD OF GROUP NAME
  
 ONIA     RJ     IIR         ISSUE IOLST TO RLIST 
          SA3    SYMORD      SYMTAB ORD 
          SB1    X3          RESTORE B1 
  
 ONI      ENTRY. *           ENTRY/EXIT 
          SA3    =XOPT2 
          ZR     X3,ONI      EXIT IF NOT IN OPT=2 
          MX0    -L.DIMP
          LX2    -P.DIMP
          SA1    O.NML
          BX4    -X0*X2      ORDINAL TO NML TABLE 
          ZR     X4,ONI      EXIT, ERROR IN NAMELIST STMT 
          IX3    X1+X4
          SA5    X3          HDR WORD 
          ZR     X5,ONI      EXIT, NO NAMELIST VARIABLES
          SX6    B1 
          SA6    SYMORD      SAVE TO BE RESTORED AT EXIT
          IX7    X4-X5       INDEX TO FIRST VARIABLE
          SX6    X5          LENGTH OF VARIABLES
          SA7    TINDX
          SA6    TLEN 
  
          ALLOC  IOLST,X5    ALLOC FOR TRANSFER FROM NML
  
          SA2    TINDX       INDEX TO NML TABLE 
          SA1    IOFLAG 
          MX7    0
          SA5    TLEN        NO. OF NAMELIST VARIABLES
          ZR     X1,ONI1     IF NOT INPUT STMT
          MX7    2
          LX7    2+AP.USEP   SHOW USE/DEF 
  
 ONI1     SA1    L.IOLST
          IX6    X1+X5       UPDATE LENGTH FOR NAMELIST VARIABLES 
          SA4    O.NML
          SA6    A1 
          IX2    X2+X4       ADDR OF FIRST ENTRY IN NML 
          SA3    O.IOLST
          IX1    X1+X3       ADDR OF FIRST SPACE IN IOLST 
          SB6    X5-1        COUNTER FOR TRANSFER 
  
 ONI2     SA3    X2+B6       FETCH NML ENTRY
          BX6    X7+X3       OR IN IO BIT 
          SA6    X1+B6       STORE IN IOLST 
          SB6    B6-B5
          PL     B6,ONI2     IF MORE ITEMS TO TRANSFER
          EQ     ONIA 
  
          TITLE              MACOUT - OUTPUT RLIST MACRO
**        MACOUT - OUTPUT I/O MACRO TO RLIST
*         PACKS PARAMETERS STORED IN MACLS1 TO MACLK3 INTO
*         RLIST MACRO FORMAT , OUTPUTS MACRO TO RLIST  AND
*         AND CLEAR OUT THE AREA FROM MACLS2 - MACLK3 
  
 MACOUT1  SA1    A3+B5             PACK THE RNUMBERS AND CONS 
          SA2    A1+B5
          SB2    X5 
          LX2    B2,X2
          SA3    A2+B5
          SB3    B2+B2
          BX4    X2+X1
          LX3    B3,X3
          BX7    X3+X4
          AX5    18 
          SA7    A7+B5
          NZ     X5,MACOUT1        LOOP FOR 3 WORDS 
          SA3    A3+B5             COPY MACLK4
          BX7    X3 
          SA7    A7+B5
  
          SB7    B1 
          SB1    1
          WRITEW =XF.RLST,MACBUF,B7 
          SB5    1
          SA5    MACOPC 
          ZR     X5,COLAPXX  SKIP IF FIRST
          SX6    X5-5 
          ZR     X6,COLAPXX  SKIP IF LAST 
  
          SA5    NRLN 
          BX6    X5          RESULT R NUMBER
          SA6    TEMPA
          SX7    X5+B5       NRLN=NRLN+1
          SA7    A5 
          SA2    MACLP2      FWA
          SA1    MACLP1      ITEM COUNT 
          LX6    RM.RIL 
          BX7    X6+X2
          LX7    RM.RIL 
          BX7    X7+X1
          SA7    WWCA 
          SA1    MACLK4      TYPE 
          BX6    X1 
          SA6    A7+B5
          WRM    IOAPL       OUTPUT IOAPL MACRO 
  
 COLAPXX  SB3    MACLS2 
          SB4    A3+B5             LWA+1
          MX6    0
+         SA6    B3                CLEAR OUT MACRO PARAMETER BUFFER 
          SB3    B3+B5
          LT     B3,B4,*
          SB5    1
  
 MACOUT   ENTRY. *                 ** ENTRY/EXIT ** 
          SA5    MACOP
          SB7    MACBUF            FWA OF BUFFER
          SX0    6                 (4+1)/2 + (6+2)/3 + (4+2)/3
          SB1    X0+B5
          SB2    X5 
          LX0    30 
          SA4    NRLN 
          BX0    X0+X4
          SB3    -B2
          PX6    B3,X0
          SA6    B7                RMACRO HEADER WORD 
  
          SA5    SHIFTWD           SHIFT COUNT FOR RNUMBERS AND CONS
          SA1    MACLS1 
          SA2    A1+B5
          SA4    A2+B5             SYM3 
          LX2    30 
          SA3    A4+B5
          BX6    X2+X1
          LX3    30 
          BX7    X3+X4
          SA6    A6+B5             STORE SYM S
          SA7    A6+B5
          EQ     MACOUT1
  
 SHIFTWD  VFD    6/0,18/18,18/16,18/16
  
          END 
