*DECK     IO
          IDENT  IO 
 IO       SECT   (INPUT/OUTPUT STATEMENT PROCESSING.) 
 IO       SPACE  4
*         IN ALLOC
          EXT    ADW,ALC
  
*         IN CONRED 
          EXT    LCH,LCT
  
*         IN FEC
          EXT    ARGCOMA,ARGMODE,BBC,CHARMAP,CT1,DATFLG,ERT,ESY,NCS,OIL 
          EXT    PARMODE,REFNUM,REFVAR,SSY,TSX
  
*         IN FERRS
          EXT    E.ANS,E.IOB0,E.IOB1,E.IOB2,E.IOB3,E.IOB4,E.IOB5
          EXT    E.IOB6,E.IOB7,E.IOB8,E.IOB9,E.IO36,E.IO37
          EXT    E.IOD1,E.IOD2,E.IOD3,E.IOD4,E.IOF,E.IOF1,E.IOF2
          EXT    E.IOL1,E.IOL2,E.IOL5,E.IOL6,E.ION,E.ION1 
          EXT    E.IOS1,E.IOS2,E.IOS3,E.IOS4,E.IOS5,E.IOS6,E.IOS7,E.IOS8
          EXT    E.IOS9,E.IOS10,E.MDE3,E.MDE4 
          EXT    E.IO00,E.IO01,E.IO02,E.IO03,E.IO04,E.IO05,E.IO06,E.IO07
          EXT    E.IO08,E.IO09,E.IO10,E.IO11,E.IO12,E.IO13,E.IO14,E.IO15
          EXT    E.IO16,E.IO17,E.IO18,E.IO19,E.IO20,E.IO21,E.IO22,E.IO23
          EXT    E.IO24,E.IO25,E.IO26,E.IO28,E.IO29,E.IO30,E.IO31 
          EXT    E.IO32,E.IO33,E.IO34,E.IO35,FILL.,FILL.2,FILL.3,MOD.DPC
  
*         IN FSNAP
          EXT    LTB= 
  
*         IN FTN
          EXT    CO.SNAP,CO.DBSB
  
*         IN LABEL
          EXT    CDI,DDR,ISL,PDT,PSL
  
*         IN PAR
          EXT    BUFFWA,BUFLWA,BUFMOD,CNTARM,CURST,C=ERR,DOCOLI,DOCOLS
          EXT    DOA,EMT,ERROP,FAT,FMTARM,ICCARM,ICCXARM,ICIARM,ICIXARM 
          EXT    ICLARM,IOARGM,IOCTL,IODTA,IOL.RTN,IOUNT,OPBSS,OPDUM,PAR
          EXT    PAREXIT,PAR.NX,STRARM,TPC,UNTARM,FOUARM,GOL
          EXT    ARYOP
  
*         IN PEM
          EXT    ANSI=,MDERR=,PDM 
  
*         IN PUC
          EXT    CONONE,CONZER,LOSTREF,N.GL,SCR,S=BU,S=CON,S=VD,T=IOARG 
          EXT    T=BLST,T=ILI,T=IOA,T=IOLC,T=PAR,T=REF,T=SCR,T.IOARG
          EXT    T.DIM,T.ILI,T.IOA,T.IOLC,T.PAR,T.SCR,T.SYM,T.TB,WO.DOOT
          EXT    WO.LOA,WO.LOM,WO.LOR 
  
*         IN QSKEL/FSKEL
          EXT    V=APIOC,V=IOLC,V=IOSUB,V=LCIF,V=MUL,V=MUL.I,V=NOOP 
          EXT    V=STR.I,V=MAX0,V=SUB.I,V=ADD.I 
  
*         IN UTILITY
          EXT    CDD,MVE= 
          TITLE  STORAGE AND TABLES.
**        MISCELLANEOUS CELLS USED BY I/O PROCESSORS
  
  
 IODIR    CONENT 0           I/O DIRECTION (S=INP OR S=OUT) 
 IOARGT   BSS    1           (ARGMODE) FOR THIS DIRECTION 
 IOREF    BSS    1           I/O REFERENCE LETTER 
 IODTH    BSS    1           DATA TURPLE HEADER 
 IOSKP    BSS    1           TAG FOR SKIP= LABEL
 IOARY    BSS    1           ARRAY LOAD TURPLE HEADER 
  
 IONAM    BSSENT 1           ORDINAL OF I/O ROUTINE NAME (IN S.LIB) 
                             COMPLEMENTED UNTIL INITIAL CALL COMPILED.
  
 IODOCOL  BSS    1           POINTER TO LAST PROCESSED I/O DO STRUCTURE 
 IODOLEN  BSZENT 1           LENGTH OF DO-TABLE BEFORE THIS STATEMENT 
 IODOIND  BSZENT 2           INDICATOR THAT PARTIAL COLLAPSE OCCURRED 
                             SECOND WORD IS THE COLLAPSE COUNT
  
 IOBFWA   BSS    1           BUFFER I/O FIRST WORD ADDRESS
 IOBLWA   BSS    1           BUFFER I/O LAST WORD ADDRESS 
  
 LISTDIR  CON    0           LIST DIRECTED I/O FLAG 
 S.IOCALL SPACE  4,10 
**        S.IOCALL - LIST OF ROUTINES USED BY OBJECT TIME INPUT/OUTPUT. 
*         MUST ALWAYS BE KEPT IN ORDER, AS THE PROPER NAME IS  SELECTED 
*         BY INDEXING INTO THIS TABLE.
  
  
 S.IOCALL BSS    0           BASE OF *I/O* ROUTINE NAMES
  
          LOC    0
 S=COD    BSS    0           *CODED* MODE 
 S=INIT   BSS    0           *INITIAL* CALL 
 S=INP    =XLIB  INPCI       *INPUT* DIRECTION
 S=CONT   =XLIB  INPCR
 S=OUT    =XLIB  OUTCI       *OUTPUT* DIRECTION 
          =XLIB  OUTCR
 S=BIN    =XLIB  INPBI       *BINARY* MODE
          =XLIB  INPBR
          =XLIB  OUTBI
          =XLIB  OUTBR
 S=FREE   =XLIB  INPFI       *LIST-DIRECTED* (FREE FIELD) 
          =XLIB  INPFR
          =XLIB  OUTFI
          =XLIB  OUTFR
 S=STR    =XLIB  DECODI      *STRING* MODE
          =XLIB  DECODR 
          =XLIB  ENCODI 
          =XLIB  ENCODR 
 S=INF    =XLIB  IIFCI       *INTERNAL FILE*
          =XLIB  IIFCR
          =XLIB  OIFCI
          =XLIB  OIFCR
 S=DA     =XLIB  IDACI       *DIRECT ACCESS* MODE 
          =XLIB  IDACR
          =XLIB  ODACI
          =XLIB  ODACR
          =XLIB  IDABI
          =XLIB  IDABR
          =XLIB  ODABI
          =XLIB  ODABR
          LOC    *O 
  
 S.NLST   =XLIB  NAMIN       *NAMELIST* MODE
          =XLIB  NAMOUT 
 S.BKSP   =XLIB  BACKSP 
 S.CLOSE  =XLIB  CLOSE
 S.ENDFI  =XLIB  ENDFIL 
 S.INQUI  =XLIB  INQUIR 
 S.OPEN   =XLIB  OPEN 
 S.REWIN  =XLIB  REWIND 
          =XLIB  BUFOUT 
 S.BUFIO  =XLIB  BUFIN
  
 S=NLST   EQU    -3          NAMELIST INDICATOR 
 DC=      SPACE  4,10 
**        DO COLLAPSE POINTER VALUES
*         INDEX INTO TOKEN BUFFER, BEGINNING WITH COLLAPSE CONCLUDE 
  
  
 DC=CCT   EQU    0           DO COLLAPSE CONCLUSION TOKEN 
 DC=ISV   EQU    1           INITIAL SUBSCRIPT VALUE
 DC=SIZ   EQU    2           COLLAPSE SIZE
 DC=VAR   EQU    3           VARIABLE FOR SIZE MULTIPLY 
 DC=OFF   EQU    4           STARTING OFFSET (BIAS) 
 KW.CTL   EJECT 
**        FW.CTL - *I/O CONTROL* SUB-KEYWORD TABLE. 
  
 FW.CTL   BSS    0           FWA OF *I/O CONTROL* SUB-KEYWORD TABLE 
  
  
**        IODEF - MACRO TO DEFINE I/O CONTROL SUB-KEYWORD TABLE 
  
  
          PURGMAC  ICDEF
          MACRO  ICDEF,INFO,KEY 
 A        MICRO  1,, KEY
 B        MICCNT A
 C        MICRO  B,1, KEY 
 .1       IFC    EQ,/"C"/=/ 
 D        MICRO  1,B-1, KEY 
          SUBKEY "D",PKC=INFO 
 .1       ELSE
          SUBKEY $,PKC= 
 .1       ENDIF 
 ICDEF    ENDM
  
  
*CALL COMSIOC 
  
 L.CTL    EQU    *-FW.CTL    LENGTH OF *I/O CONTROL* SUB-KEYWORD TABLE
          TITLE  AUXILIARY I/O STATEMENTS - SOURCE TRANSLATION. 
 BACKSPAC SPACE  4,10 
**        PROCESS "BACKSPACE" STATEMENT.
* 
*         SEE ANSI 12.10.4
* 
*         EXIT   TO FPS WITH
*                (B6) _ BACKSPACE ROUTINE NAME. 
  
  
          HEREIF BACKSPACE
  
          SB6    S.BKSP 
          EQ     FPS
 CLOSE    SPACE  4,10 
***       PROCESS "CLOSE" STATEMENT.
* 
*         SEE ANSI 12.10.2
* 
*         EXIT   TO FMS WITH
*                (B6) _ CLOSE ROUTINE NAME
*                (X1) = "CLLC" (KEYWORD LEGALITY MASK)
  
  
 CLLC     BITMIC (IC.UNT,IC.ERR,IC.IOS,IC.STA)
  
          HEREIF CLOSE
          SB6    S.CLOSE
          SA1    ="CLLC"     FETCH LEGALITY MASK
          EQ     FMS
 ENDFILE  SPACE  4,10 
**        PROCESS "ENDFILE" STATEMENT.
* 
*         SEE ANSI 12.10.4
* 
*         EXIT   TO FPS WITH
*                (B6) _ ENDFILE ROUTINE NAME. 
  
  
          HEREIF ENDFILE
  
          SB6    S.ENDFI
          EQ     FPS
 INQUIRE  SPACE  4,10 
**        PROCESS "INQUIRE" STATEMENT.
* 
*         SEE ANSI 12.10.3
* 
*         EXIT   TO FMS WITH
*                (B6) _ INQUIRE ROUTINE NAME
*                (X1) = "INCL" (KEYWORD LEGALITY MASK)
  
  
 INCL     BITMIC (IC.UNT,IC.ERR,IC.IOS,IC.ACC,IC.BLK,IC.DIR,IC.EXS,_____
,IC.FIL,IC.FOR,IC.FMD,IC.NAM,IC.NMD,IC.NXT,IC.NUM,IC.OPE,IC.RCL,IC.SEQ,_
,IC.UNF)
  
          HEREIF INQUIRE
          SB6    S.INQUI
          SA1    ="INCL"     FETCH LEGALITY MASK
          EQ     FMS
 OPEN     SPACE  4,10 
**        PROCESS "OPEN" STATEMENT. 
* 
*         SEE ANSI 12.10.1
* 
*         EXIT   TO FMS WITH
*                (B6) _ OPEN ROUTINE NAME.
*                (X1) = "OPLC" (KEYWORD LEGALITY MASK)
  
  
 OPLC     BITMIC (IC.UNT,IC.ERR,IC.IOS,IC.ACC,IC.BLK,IC.BFL,IC.FIL,_____
,IC.FOR,IC.RCL,IC.STA)
  
          HEREIF OPEN 
          SB6    S.OPEN 
          SA1    ="OPLC"     FETCH LEGALITY MASK
          EQ     FMS
 REWIND   SPACE  4,10 
**        PROCESS "REWIND" STATEMENT. 
* 
*         SEE ANSI 12.10.4
* 
*         EXIT   TO FPS WITH
*                (B6) _ REWIND ROUTINE NAME.
  
  
          HEREIF REWIND 
  
          SB6    S.REWIN
          EQ     FPS
 FMS      SPACE  4,10 
**        FMS -  PROCESS FILE MANIPULATION STATEMENTS 
* 
*         ENTRY  (B6) _ NAME OF FILE MANIPULATION ROUTINE (*TB* FORMAT) 
*                (X1) = KEYWORD LEGALITY MASK FOR CURRENT STATEMENT.
* 
*         EXIT   TO PSL 
* 
*         CALLS  ALC, CUD, EMT, IOJ, PCT, PKC, SFP, TSX 
  
  
 FMS      SX7    CR.REF 
          SA7    IOREF       SET XREF CELL TO * * 
          SX6    0
          SA6    PKCA        INITIALIZE 
          SA6    IOSKP       CLEAR
          SA6    CVLPM       INITIALIZE 
          ERRNZ  PM=EXPR
          MX7    1
          BX6    X1 
          SA7    IODIR       INDICATE NO ASSUMED UNIT OR INTERNAL FILE
          SA6    FMSA        SAVE LEGALITY MASK 
          ALLOC  T.IOARG,Z=TURP    FOR UNIT DESIGNATOR
          SA2    B4 
          SB2    X2-O.( 
          ZR     X2,E.IO01   IF PREMATURE *EOS* 
          NZ     B2,E.IO19   IF NOT *(* 
          =B4    B4+1 
          =A2    B4+1 
          SB7    X2-O.= 
          ZR     B7,FMS3     IF *=* 
          RJ     CUD         COMPILE THE UNIT DESIGNATOR
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.) 
          SB3    X1-O.COMMA 
          MX3    0
          ZR     B2,FMS4A    IF *)*, FINISH 
          NZ     B3,E.IO16   IF NOT *,*, ERROR
          =X6    1
          LX6    59-IC.UNT
          SA6    PKCA        INDICATE I/O UNIT DEFINED
          =B4    B4+1 
  
 FMS3     SA1    B4 
          SX1    X1-O.VAR 
          NZ     X1,E.IO16   IF NOT O.VAR TOKEN (CANT BE KEYWORD) 
          SA1    FMSA        FETCH KEYWORD LEGALITY MASK
          RJ     PKC         PROCESS KEYWORD CONTROL ITEMS
          RJ     OST         OUTPUT SKIP TURPLE 
          SA3    PKCA 
  
 FMS4A    =A1    B4+1 
          SB4    B4+1        ADVANCE B4 
          ZR     X1,FMS4     IF *EOS*, FINISH 
          ERRNZ  O.EOS
          WARN   E.IO37      IF NOT *EOS* 
  
 FMS4     RJ     SFP         SET FILE PROPERTY BITS 
          TAGSEX B6          PROCESS I/O ROUTINE NAME 
          SB3    S.IOCALL 
          SX7    B3-B6       NEGATIVE ORDINAL = FIRST CALL
          BX6    0
          SA7    IONAM
          RJ     IOJ
          SA4    IOSKP
          ZR     X4,PSL      IF NO SKIP LABEL 
          MX5    0           2OP = NULL 
          EMIT   OPBSS,*
          EQ     PSL         EXIT...
  
 FMSA     BSS    1           SAVE KEYWORD LEGALITY MASK 
 FPS      SPACE  4,10 
**        FPS -  PROCESS FILE POSITIONING STATEMENTS
* 
*         ENTRY  (B6) _ NAME OF FILE POSITIONING ROUTINE (*TB* FORMAT). 
* 
*         EXIT   TO PSL 
* 
*         CALLS  ALC, CUD, EMT, IOJ, OCT, PCT, PKC, TSX 
  
  
 FPLC     BITMIC (IC.ERR,IC.IOS,IC.UNT) 
  
 FPS      SX7    CR.REF 
          SA7    IOREF       SET XREF CELL TO * * 
          SX6    0
          SA6    PKCA        INITIALIZE 
          SA6    IOSKP       CLEAR
          SA6    CVLPM       INITIALIZE 
          ERRNZ  PM=EXPR
          MX7    1
          SA7    IODIR       INDICATE NO ASSUMED UNIT OR INTERNAL FILE
          ALLOC  T.IOARG,Z=TURP    FOR UNIT DESIGNATOR
          SA2    B4 
          SA1    B4+B1
          SB2    X2-O.( 
          ZR     X2,E.IO01   IF PREMATURE *EOS* 
          ZR     B2,FPS2     IF *(* 
          RJ     CUD         COMPILE THE UNIT DESIGNATOR
          =A1    B4+1 
          ZR     X1,FPS4     IF *EOS* 
          =B4    B4+1 
          WARN   E.IO06      EXTRA CHARACTERS - WARNING 
          EQ     FPS4        FINISH PROCESSING
  
*         PROCESS CONTROL ITEM LIST 
  
 FPS2     =B4    B4+1 
          =A2    B4+1 
          SB2    X2-O.= 
          ZR     B2,FPS3     IF KEYWORD FORM
          RJ     CUD         COMPILE THE UNIT DESIGNATOR
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.) 
          SB3    X1-O.COMMA 
          ZR     B2,FPS4     IF *)*, FINISHED 
          NZ     B3,E.IO16   IF NOT *,*, ERROR
          =X6    1
          LX6    59-IC.UNT
          SA6    PKCA        INDICATE I/O UNIT DEFINED
          =B4    B4+1 
  
 FPS3     SA1    ="FPLC"     KEYWORD LEGALITY MASK
          RJ     PKC         PROCESS KEYWORD CONTROL ITEMS
          RJ     OST         OUTPUT SKIP TURPLE 
 FPS4     TAGSEX B6          PROCESS I/O ROUTINE NAME 
          SB3    S.IOCALL 
          SX7    B3-B6       NEGATIVE ORDINAL = FIRST CALL
          BX6    0
          SA7    IONAM
          RJ     IOJ
          SA4    IOSKP
          ZR     X4,PSL      IF NO SKIP LABEL 
          MX5    0           2OP = NULL 
          EMIT   OPBSS,*
          EQ     PSL         EXIT...
          TITLE  DATA TRANSFER I/O STATEMENTS - SOURCE TRANSLATION. 
 PRINT    SPACE  4,10 
**        PROCESS "PRINT" STATEMENT.
* 
*         SEE ANSI 12.8 
* 
*         EXIT   TO *PIC* WITH -- 
*                (X5) = *OUTPUT* FILE 
*                (X7) = CR.OUT
*                (B4) _ FORMAT DESIGNATOR 
*                (B6) = S=OUT 
  
  
          HEREIF PRINT
  
          SX7    CR.OUT 
          SB6    S=OUT
          SA5    =0LOUTPUT
          EQ     PIC         PROCESS REMAINDER OF STATEMENT 
 PUNCH    SPACE  4,10 
**        PROCESS "PUNCH" STATEMENT.
* 
*         NON-ANSI:  SEE ERS 12.8 
* 
*         EXIT   TO *PIC* WITH -- 
*                (X5) = *PUNCH* FILE
*                (X7) = CR.OUT
*                (B4) _ FORMAT DESIGNATOR 
*                (B6) = S=OUT 
  
  
          HEREIF PUNCH
  
          ANSI   E.ANS       *PUNCH* STATEMENT IS NON-ANSI
          SA5    =0LPUNCH 
          SX7    CR.OUT 
          SB6    S=OUT
          EQ     PIC         PROCESS REMAINDER OF STATEMENT 
 READ     SPACE  4,10 
**        PROCESS "READ" STATEMENT. 
* 
*         SEE ANSI 12.8 
* 
*         EXIT TO *PIC* WITH -- 
*                (X5) = *INPUT* FILE
*                (X7) = CR.INP
*                (B4) _ FORMAT DESIGNATOR 
*                (B6) = S=INP 
* 
*           OR TO *PEC* WITH -- 
*                (B4) _ *(* 
*                (X1) = KEYWORD LEGALITY MASK 
*                (X5),(X7),(B6) AS ABOVE
  
          HEREIF READ 
  
 RLC      BITMIC (IC.UNT,IC.END,IC.ERR,IC.FMT,IC.IOS,IC.REC)
  
          SA1    B4 
          =B6    S=INP
          SX7    CR.INP 
          SA5    =0LINPUT 
          SX2    X1-O.( 
          SA1    ="RLC"      KEYWORD LEGALITY MASK
          ZR     X2,PEC      IF *READ(* 
          EQ     PIC         PROCESS *READ FMT,*
 WRITE    SPACE  4,10 
**        PROCESS "WRITE" STATEMENT.
* 
*         SEE ANSI 12.8 
* 
*         EXIT TO *PEC* WITH -- 
*                (X1) = KEYWORD LEGALITY MASK 
*                (X7) = CR.OUT
*                (B4) _ *(* 
*                (B6) = S=OUT 
  
  
          HEREIF WRITE
  
 WLC      BITMIC (IC.UNT,IC.ERR,IC.FMT,IC.IOS,IC.REC) 
  
          SA1    B4 
          SX7    CR.OUT 
          =B6    S=OUT
          SX2    X1-O.( 
          SA1    ="WLC"      KEYWORD LEGALITY MASK
          ZR     X2,PEC      IF *WRITE(*
          EQ     E.IO19 
 PIC      SPACE  4,10 
**        PIC -  PROCESS IMPLIED CONTROL LIST 
* 
*         ENTERED BY *PRINT*, *PUNCH* AND *READ FMT,* 
* 
*         ENTRY  (X5) = DEFAULT UNIT DESIGNATOR 
*                (X7) = CROSS REFERENCE INDICATOR 
*                (B4) _ FORMAT DESIGNATOR 
*                (B6) = I/O DIRECTION (S=INP OR S=OUT)
* 
*         EXIT   TO *LST* WITH -- 
*                (B6) = DIRECTION + CODED MODE (S=COD) INDICATION.
* 
*         CALLS  EMT, IIC, NCS, PFN 
  
  
 PIC      SA7    IOREF       CROSS REFERENCE INDICATOR
          SX6    0
          SA6    PKCA        INITIALIZE 
          BX6    X5 
          =X7    M.BOOL 
          CALL   NCS         FILE DESIGNATOR INTO CONSTANT TABLE
          SA5    CONONE 
          BX4    X6          UNIT DESIGNATOR
          EMIT   IOUNT,*,T.IOARG
          ERRNZ  M.BOOL      MUST MERGE MODE INTO HEADER
          RJ     IIC         INITIALIZE CONTROL CELLS 
          RJ     PFN         PROCESS FORMAT/NAMELIST DESIGNATOR 
          =A1    B4+1 
          =B4    B4+1 
          SB7    X1-O.COMMA 
          ZR     X1,LST      IF NO LIST 
          NZ     B7,E.IO16   IF NO COMMA SEPARATOR
          EQ     LST
 PEC      SPACE  4,10 
**        PEC -  PROCESS EXPLICIT CONTROL LIST
* 
*         ENTERED BY *READ(* AND *WRITE* STATEMENTS.
* 
*         ENTRY  (B6) = I/O DIRECTION (S=INP OR S=OUT)
*                (B4) _ *(* 
*                (X1) = KEYWORD LEGALITY MASK.
*                (X7) = CROSS REFERENCE INDICATOR 
* 
*         EXIT   TO *LST* WITH -- 
*                (B6) = DIRECTION + CODED MODE (S=COD) INDICATION 
* 
*         CALLS  ALC, CUD, IIC, PFN, PKC, SFP, OUT, UDP, PAR, TPC.
  
  
 PEC      SA7    IOREF       CROSS REFERENCE INDICATOR
          SA5    =0LINPUT 
          SX7    B6-S=INP 
          ZR     X7,PEC10    IF INPUT DIRECTION 
          SA5    =0LOUTPUT
  
 PEC10    BX6    X5 
          SA6    PECB        PRESERVE DEFAULT UNIT DESIGNATOR 
          =X6    0
          BX7    X1 
          SA6    PKCA        INITIALIZE 
          SA7    PECA        SAVE KEYWORD LEGALITY MASK 
          ALLOC  T.IOARG,Z=TURP    FOR UNIT DESIGNATOR
          RJ     IIC         INITIALIZE CONTROL CELLS 
          =B4    B4+1 
          =A2    B4+1 
          SA1    B4+
          SX1    X1-O.STAR
          ZR     X1,PEC80    IF DEFAULT UNIT DESIGNATOR 
          SX2    X2-O.= 
          ZR     X2,PEC170    IF KEYWORD FORM 
          =A2    B4-1        X2 = *(* 
          LX2    -TB.IOCPP
          SX2    X2 
          ZR     X2,PEC80    IF NO MATCHING RP
          =A2    X2+1        X2 = TOKEN AFTER MATCHING RP 
          SX1    X2-O.COMMA 
          SX3    X2-O.CAT 
          SA4    IODIR
          NZ     X1,PEC20    IF NO COMMA
          NZ     X4,PEC80    IF *WRITE(XXXXX),* 
          ERRNZ  S=INP
          EQ     PEC70
  
 PEC20    NZ     X3,PEC30    IF NO CAT
          NZ     X4,PEC80    IF *WRITE(XXXX)//* 
          ERRNZ  S=INP
          EQ     PEC70
  
 PEC30    NZ     X2,PEC80    IF CONTROL LIST
          SX1    B4          LOOP START 
          SX2    A2          LOOP END 
  
 PEC40    SA3    X1          X3 = NEXT TOKEN
          SB2    X3-O.COMMA 
          SB7    X3-O.LP
          LX3    -TB.IOCPP
          =X1    X3+1        X1 = ADDRESS OF POSSIBLE MATCHING RP + 1 
          ZR     B7,PEC40    IF LEFT PAREN
          ZR     B2,PEC80    IF ZERO LEVEL COMMA
          =X1    A3+1 
          IX3    X1-X2
          MI     X3,PEC40    IF MORE TOKENS 
  
**        HERE IF NO ZERO LEVEL COMMA INSIDE PARENS.
*         MUST CALL PAR TO FIND OUT IF EXPRESSION IS UNIT OR FORMAT 
  
          SA1    FOUARM 
          SX6    B6 
          SA6    CUDA        PRESERVE B6
          MX6    0
          SA6    LISTDIR
          =B4    B4-1        B4 _ *(* 
          SX6    O.SLP
          SA6    B4          TURN O.LP INTO O.SLP 
          BX6    X1 
          SA6    ARGMODE     SET *FORMAT OR UNIT* ARGMODE 
          CALL   PAR         PARSE THE EXPRESSION 
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX1    -X0*X5      EXTRACT MODE OF RESULT 
          LX5    TP.MODEP 
          SX1    X1-M.CHAR
          NZ     X1,PEC50    IF NOT CHARACTER (NOT A FORMAT)
          SA3    IODIR
          =B4    B4+1        B4 _ *)* 
          SB2    S=INF
          NZ     X3,PEC110   IF *WRITE(CEXP) *
          SA1    CUDA 
          SB6    X1          RESTORE B6 
          =B4    B4+1        B4 _ BEGINING OF I/O LIST (EOS)
          EQ     LST
  
**        EXPRESSION MUST BE A UNIT DESIGNATOR IF HERE. COMPLETE
*         PROCESSING AS SUCH. 
  
 PEC50    SA2    CUDA 
          MX6    1
          =A6    A2+1        INDICATE UNIT NOT CONSTANT (INITIALLY) 
          LX1    X5 
          BX4    X5 
          SA5    CONONE 
          SB6    X2 
          CALL   LCH         LOAD CONSTANT TEST 
          SB3    X0-M.INT 
          ZR     X0,PEC60    IF BOOLEAN 
          ZR     B3,PEC60    IF INTEGER 
          SA4    S=BU 
          FATAL  E.IO00      ** UNIT DESIGNATOR IS BAD
          LX4    TP.ORDP
          ERRNZ  M.BOOL 
          RJ     OUT         OUTPUT UNIT DESIGNATOR TURPLE
          EQ     PEC90
  
 PEC60    RJ     UDP         UNIT DESIGNATOR PROCESSING 
          RJ     OUT         OUTPUT UNIT TURPLE 
          EQ     PEC90
  
**        HERE IF  *(EXP),* OR *(EXP)//* . EXPRESSION MUST
*         BE A CHARACTER FORMAT DESIGNATOR. 
  
 PEC70    SA1    B4           GET FIRST TOKEN AFTER LP
          SX3    X1-O.VAR     IF VARIABLE TOKEN 
          ZR     X3,PEC75     POSSIBLE CHARACTER FORMAT 
          SX3    X1-O.LP      IF LEFT PAREN 
          ZR     X3,PEC75 
          SX3    X1-O.CHAR    IF CHARACTER CONSTANT 
          NZ     X3,PEC80     CANNOT BE CHARACTER FORMAT
  
 PEC75    =B4    B4-1         B4 POINTS TO FORMAT 
          SA1    IOREF
          BX7    X1 
          SHRINK T=IOARG     NO NEED FOR ROOM FOR UNIT DESIGNATOR 
          SA5    PECB        X5 = DEFAULT UNIT DESIGNATOR 
          EQ     PIC         PROCESS AS IMPLIED CONTROL LIST
  
 PEC80    RJ     CUD         COMPILE UNIT DESIGNATOR
  
 PEC90    SB6    B6+B2       ADJUST IF INTERNAL FILE
          =X6    1
          LX6    59-IC.UNT
          SA6    PKCA        INDICATE I/O UNIT DEFINED
          =A1    B4+1        RIGHT PAREN OR COMMA 
          =B4    B4+1 
          SB7    X1-O.) 
          SA3    IODIR
          NZ     B7,PEC140   IF NOT *)* 
  
 PEC110   SX1    B2-S=INF 
          NZ     X1,PEC130   IF NOT AN INTERNAL FILE
          SB7    E.IO34      ** INTERNAL FILE REQUIRES A FORMAT 
          NZ     X3,PEC120   IF *WRITE(CEXP)VAR*
          SB7    E.IO35      ** MISSING COMMA OR MISSING FORMAT 
  
 PEC120   FATAL  B7 
  
 PEC130   =B6    B6+S=BIN 
          SA3    PKCA 
          RJ     SFP         SET FILE PROPERTIES
          EQ     LST
  
 PEC140   ZR     X1,E.IO08   IF PREMATURE *EOS* 
          SB2    X1-O.COMMA 
          ZR     B2,PEC150   IF *COMMA* 
          WARN   E.IO09      ** ASSUMED COMMA AFTER UNIT ** 
  
 PEC150   =A1    B4+1 
          ZR     X1,E.IO13   IF PREMATURE EOS (RETURN LST)
          =B4    B4+1 
          SA2    B4+1 
          SX2    X2-O.= 
          ZR     X2,PEC170    IF KEYWORD FORM 
  
          RJ     PFN         PROCESS FORMAT/NAMELIST DESIGNATOR 
          =A1    B4+1 
          =B4    B4+1 
          ZR     X1,E.IO08   IF PREMATURE *EOS* 
          SB2    X1-O.) 
          SA3    PKCA 
          SX6    1
          LX6    59-IC.FMT
          BX6    X3+X6
          NZ     B2,PEC160
          BX3    X6 
          RJ     SFP
          EQ     LST
  
 PEC160   SA6    A3 
          =B4    B4+1 
  
 PEC170   SA1    PECA        KEYWORD LEGALITY MASK
          RJ     PKC         PROCESS KEYWORD CONTROL ITEMS
          RJ     SFP         SET FILE PROPERTY BITS 
          SX0    1
          LX0    59-IC.REC
          BX1    X3*X0
          ZR     X1,PEC180   IF REC= NOT SPECIFIED
  
*         TEST FOR DIRECT ACCESS INCONSISTENCY
  
          LX0    IC.REC-IC.NML
          BX1    X3*X0
          NZ     X1,E.IO28   IF REC= AND NAMELIST 
          LX0    IC.NML-IC.END
          BX1    X3*X0
          NZ     X1,E.IO29   IF REC= AND END= SPECIFIED 
          SB2    B6-S=FREE
          PL     B2,E.IO25   IF REC= AND FMT=*
          SB6    B6+S=DA     INDICATE DIRECT ACCESS 
 PEC180   SX0    1
          LX0    59-IC.FMT
          BX0    X3*X0
          SA3    IODIR
          ZR     X0,PEC130   IF NOT FORMATTED 
          EQ     LST         PROCESS THE I/O LIST 
  
 PECA     EQU    FMSA        SAVE KEYWORD LEGALITY MASK 
 PECB     BSS    1           PRESERVE DEFAULT UNIT DESIGNATOR HERE
          TITLE  NON ANSI I/O STATEMENTS - SOURCE TRANSLATION.
 BUFFER   SPACE  4,10 
**        PROCESS "BUFFER IN/OUT" STATEMENTS. 
* 
*         NON-ANSI:  SEE ERS 12.16
* 
*         BUFFER <DIR> (<FILE>,<MODE>) (FWA,LWA)
*         <DIR>  #  *IN* OR *OUT* 
*         <FILE> # AS DEFINED BY *CUD*
*         <MODE> #  <INTEGER-CONSTANT> OR <SIMPLE-INTEGER-VARIABLE> 
* 
*         CALLS  ALC, CUD, IIC, IOJ, PAR, PCT, SFP, TSX 
  
  
          HEREIF BUFFER 
  
          ANSI   E.ANS       NON ANSI STATEMENT.
          MDERR  E.MDE3      ** BUFFER IO IS MACHINE DEPENDENT
          SA5    B4 
          SA2    BUFA 
          =A3    A2+1 
          =B5    0           INDICATE INPUT 
          =B6    S=INP       INDICATE INPUT 
          BX2    X5-X2
          =A1    A5+1        *(*
          SB2    X1-O.LP
          BX3    X5-X3
          =B4    B4+1 
          ZR     X2,BUF1     IF *IN*
          =B5    1           INDICATE OUTPUT
          =B6    S=OUT       INDICATE OUTPUT
          NZ     X3,E.IOB1   IF NOT *OUT*, ERR..
 BUF1     ZR     B2,BUF2     IF SYNTAX OK 
          EQ     E.IOB3 
  
 BUF2     RJ     IIC         INITIALIZE I/O CONTROL 
          SB6    S.BUFIO
          SB6    B6-B5       ADJUST FOR I/O DIRECTION 
          TAGSEX B6          PROCESS I/O ROUTINE NAME 
          SB3    S.IOCALL 
          SX6    B3-B6       NEGATIVE ORDINAL = FIRST CALL
          SA6    IONAM       SAVE ROUTINE NAME
  
**        PROCESS UNIT DESIGNATOR 
  
          =B4    B4+1        POSITION TO UNIT DESIGNATOR
          SA1    IODIR
          BX6    -X1
          SA6    A1          SET IODIR NEGATIVE TO PREVENT FUNNY UNITS
          ALLOC  T.IOARG,Z=TURP    FOR UNIT DESIGNATOR
          RJ     CUD         COMPILE THE UNIT DESIGNATOR
          =X3    1
          RJ     SFP         SET FILE PROPERTY BITS 
          =B4    B4+1 
  
**        PROCESS MODE DESIGNATOR 
  
          =A2    B4 
          SB7    X2-O.COMMA 
          NZ     B7,E.IOB4
          SA2    BUFMOD 
          SA1    IOREF
          SX6    55B
          BX1    X6-X1
          LX1    AM.REFP
          BX6    X2-X1
          SA6    ARGMODE
          =X7    O.SLP
          SA7    B4 
          CALL   PAR         PARSE THE MODE DESIGNATOR
  
          SA1    B4 
          =A2    B4+1 
          =B4    A2+1        POINT TO FWA 
          =X6 
          SX1    X1-O.RP
          SX2    X2-O.LP
          NZ     X1,E.IOB5   IF NO ) AFTER MODE DESIGNATOR
          ZR     X2,BUF3     IF SYNTAX OK 
          =B4    B4-1        RESET FOR DIAGNOSTIC 
          EQ     E.IOB3 
  
**        PROCESS FWA AND LWA 
  
 BUF3     SA6    ARGCOMA
          SA2    BUFFWA 
          SA3    IOREF
          LX3    AM.REFP
          MX0    AM.REFL
          BX2    -X0*X2      CLEAR OLD REFERENCE LETTER 
          ERRNZ  60-AM.REFL-AM.REFP 
          BX7    X2+X3
          SA7    ARGMODE
          CALL   PAR         PARSE FIRST WORD ADDRESS 
          =A2    B4+1 
          =B4    B4+1 
          SB7    X2-O.COMMA 
          NZ     B7,E.IOB4   IF NO *,* AFTER FWA
  
          SA2    BUFLWA 
          SA3    IOREF
          =X7    O.SLP
          MX0    AM.REFL
          LX3    AM.REFP
          BX2    -X0*X2 
          ERRNZ  60-AM.REFL-AM.REFP 
          BX6    X3+X2
          SA7    B4 
          SA6    ARGMODE
          CALL   PAR         PARSE LAST WORD ADDRESS
          =A2    B4 
          SB7    X2-O.RP
          NZ     B7,E.IOB5   IF NO *)* AFTER LWA
          SX6    0+ 
          RJ     IOJ         COMPILE THE CALL 
          EQ     PSL         EXIT...
  
**        HERE IF FATAL ERROR IN BUFFER STATEMENT.
*                ADD *O=ERR* OPERATOR TO PARSED FILE. 
  
 BUFERR   BSSENT 0           ...RETURN FROM ERROR PROCESSOR 
          MX4    0
          =X5    0
          EMIT   ERROP,*
          EQ     PSL         EXIT...
  
 BUFA     CON    0LIN+O.VAR 
          CON    0LOUT+O.VAR
 DECODE   SPACE  4,10 
**        PROCESS "DECODE" STATEMENT. 
* 
*         NON-ANSI:  SEE ERS 12.15
* 
*         EXIT   TO *NDC* WITH
*                (B6) = OUTPUT DIRECTION INDICATION. (FOR STRING) 
  
  
          HEREIF DECODE 
  
          SB6    S=OUT
          SX7    CR.OUT 
          EQ     NDC         PROCESS ARGUMENTS AND LIST 
 ENCODE   SPACE  4,10 
**        PROCESS "ENCODE" STATEMENT. 
* 
*         NON-ANSI:  SEE ERS 12.15
* 
*         EXIT   TO *NDC* WITH
*                (B6) = INPUT DIRECTION INDICATION. (FOR STRING)
  
  
          HEREIF ENCODE 
  
          SB6    S=INP
          SX7    CR.INP 
*         EQ     NDC
 NDC      SPACE  4,10 
**        NDC -  ENCODE / DECODE ARGUMENTS. 
* 
*         ENTRY  (B4) _ *(* IN *TB* 
*                (B6) = S=INP OR S=OUT (FOR STRING-ADDRESS) 
*                (X7) = CROSS REFERENCE SYMBOL (FOR STRING) 
* 
*         EXIT   TO *LST* WITH -- 
*                (B4) _ *)* IN *TB* 
*                (B6) = S=INP OR S=OUT (FOR IOLIST) + *STRING* MODE 
* 
*         CALLS  IIC, PAR, PFN
  
  
 NDC      ANSI   E.ANS       NON-ANSI STATEMENT 
          MDERR  E.MDE4      ** ENCODE/DECODE ARE MACHINE DEPENDENT 
          SA7    IOREF
          RJ     IIC         INITIALIZE CONTROL CELLS 
  
**        ASSEMBLE RECORD LENGTH. 
  
          SA4    B4 
          =B2    X4-O.LP
          ZR     X4,E.IOS6   IF PREMATURE EOS 
          NZ     B2,E.IOS1   IF NOT LEFT PARENTHESIS, ERROR 
          SA2    IOREF
          SA1    CNTARM 
          SX6    55B
          BX2    X6-X2
          LX2    AM.REFP
          BX6    X1-X2
          SA6    ARGMODE
          SX7    O.SLP
          SA7    B4          SET FOR PAR
          CALL   PAR         PARSE RECORD COUNT 
          =A4    B4+1 
          =B4    A4+1        POINT TO FORMAT
          =B2    X4-O.COMMA 
          ZR     X4,E.IOS6   IF PREMATURE EOS 
          NZ     B2,E.IOS2   IF NO COMMA
  
**        PROCESS THE FORMAT DESIGNATOR.
  
          RJ     PFN         PROCESS THE FORMAT DESIGNATOR
          SA1    B4+
          SB2    X1-O.STAR
          ZR     B2,E.IOS8   IF LIST DIRECTED 
          MI     B6,E.IOS3   IF NAMELIST NAME 
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          ZR     X1,E.IOS6   IF PREMATURE EOS 
          NZ     B2,E.IOS4   IF NO COMMA
  
**        DIGEST STRING ADDRESS.
  
          =X6    O.SLP
          SA2    IOREF
          SA1    STRARM 
          SX7    55B
          BX2    X7-X2
          LX2    AM.REFP
          BX7    X1-X2
          SA7    ARGMODE
          SA6    B4 
          CALL   PAR         PARSE STRING ADDRESS 
          SA4    B4 
          =B2    X4-O.RP
          NZ     B2,E.IOS5   IF NO RIGHT PAREN
  
*         THE I/O DIRECTION WAS ORIGINALLY SET FOR THE STRING.  IT
*         MUST NOW BE REVERSED FOR THE I/O LIST.
  
          SA3    IODIR
          SX7    CR.INP 
          SB6    S=INP
          NZ     X3,NDC4     IF OUTPUT DIRECTION (ORIGINALLY) 
          SX7    CR.OUT 
          SB6    S=OUT
 NDC4     SX6    B6          RESET (IODIR) FOR DIAGNOSTICS
          SB6    B6+S=STR 
          SA6    A3 
          SA7    REFVAR 
          EQ     LST.S       EXIT..  (TO PROCESS I/O LIST)
          TITLE  SOURCE STATEMENT SUBROUTINES.
 CUD      SPACE  4,10 
**        CUD -  COMPILE UNIT DESIGNATOR
* 
*         CALLED BY ALL I/O STATEMENTS WHICH CONTAIN AN EXPLICIT UNIT 
*         DESIGNATOR. 
* 
*         ENTRY  (B4) _ THE UNIT DESIGNATOR IN THE *TB* 
*                (IODIR) = SIGN BIT SET IF NEITHER IMPLIED UNIT NOR 
*                          INTERNAL FILE IS ALLOWED.
* 
*         EXIT   (B4) _ LAST TOKEN OF UNIT DESIGNATOR 
*                (B2) = S=INF IF INTERNAL FILE, ELSE 0
*                UNIT DESIGNATOR TURPLE OUTPUT
*                (CUDA+1) = MI IF UNIT DESIGNATOR NOT CONSTANT
*                         = SYMTAB *WB* INDEX OF FILE OTHERWISE 
* 
*         USES   A1,A2,A3,A5,A6  X0,X1,X2,X3,X4,X5,X6 B2,B7 
* 
*         CALLS  CDD,EMT,ERT,ESY,LCH,MVE=,NCS,PAR,SSY,TPC,VAI,OUT,UDP.
  
  
  
 CUD      SUBR               ENTRY/EXIT...
          MX6    1
          =A6    CUDA+1      INDICATE UNIT NOT CONSTANT (INITIALLY) 
          SA1    B4 
          SB7    X1-O.STAR
          NZ     B7,CUD3     IF NOT IMPLIED UNIT DESIGNATOR 
          SA1    IODIR
          SB7    E.IO04      ** IMPLIED UNIT NOT ALLOWED
          MI     X1,CUD9     IF IMPLIED UNIT PROHIBITED 
          SA2    =0LINPUT 
          ZR     X1,CUD2     IF INPUT DIRECTION 
          SA2    =0LOUTPUT
 CUD2     LX6    X2 
          =X7    M.BOOL 
          CALL   NCS         SCAN IMPLIED UNIT
          BX4    X6 
          SA5    CONONE 
          EQ     CUD7 
  
 CUD3     SA1    UNTARM 
          SX7    B6 
          LX6    X1 
          SA6    ARGMODE
          SA7    CUDA        SAVE (B6)
          SX6    O.SLP
          =A6    B4-1 
          =B4    B4-1 
          CALL   PAR         PARSE THE UNIT DESIGNATOR
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
          SA1    CUDA 
          SB6    X1          RESTORE (B6) 
          LX1    X5 
          BX4    X5 
          SA5    CONONE 
          CALL   LCH         LOAD CONSTANT TEST 
          SB3    X0-M.INT 
          ZR     X0,CUD4     IF BOOLEAN 
          ZR     B3,CUD4     IF INTEGER 
          SB3    X0-M.CHAR
          SB7    E.IO00      ** UNIT DESIGNATOR NOT INTEGER NOR CHAR XPR
          NZ     B3,CUD9     IF NOT CHARACTER 
          BX5    X4 
          SA3    IODIR
          SB7    E.IO30      INTERNAL FILE NOT PERMITTED
          MI     X3,CUD9     IF INTERNAL FILE NOT ALLOWED 
          SA1    PKCA 
          SB7    E.IO33 
          SX2    1
          LX2    59-IC.NML
          BX1    X2*X1
          NZ     X1,CUD9     IF ALREADY NAMELIST
          SA1    LISTDIR
          SB7    E.IO26      **INTERNAL FILE CANT BE FREE FORMAT
          NZ     X1,CUD9     IF FREE FORMAT 
          SB3    E.IO23      INTERNAL FILE CANT BE CONSTANT/EXPRESSION
  
**        WE MUST NOW REVERSE THE I/O DIRECTION FOR VAI.
  
          SX4    S=INP
          NZ     X3,CUD3A    IF OUTPUT ORIGINAL DIRECTION 
          SX4    S=OUT
  
 CUD3A    RJ     VAI         VALIDATE ADDRESSABLE ITEM
          LX4    X5 
          BX1    X5 
          SA5    CONONE 
          SBIT   X1,TP.AREP 
          PL     X1,CUD7     IF NOT ENTIRE ARRAY
          SA2    T.SYM
          LX1    TP.AREL+TP.AREP-TP.ORDL-TP.ORDP
          AX1    -TP.ORDL    EXTRACT ORDINAL
          SB2    X1 
          LX1    1
          SX1    B2+X1       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          =B2    X1-WA.W+WB.W 
          SA1    X2+B2       FETCH *WB* 
          SA2    T.DIM
          HX1    WB.PNT 
          AX1    -WB.PNTL    EXTRACT T.DIM POINTER
          IX1    X2+X1
          SA1    X1          FETCH *DH* OF DIMENSION DESCRIPTOR 
          MX0    -DH.PSL
          LX1    -DH.PSP
          BX5    -X0*X1      EXTRACT ARRAY SIZE 
          LX5    TP.BIASP 
          SB7    E.IO24      INTERNAL FILE CANT BE ASSUMED SIZE 
          SBIT   X1,DH.ASP/DH.PSP-1 
          MI     X1,CUD9     IF ASSUMED SIZE ARRAY
          SBIT   X1,DH.VDP/DH.ASP 
          CLAS=  X2,TP,(SHRT),INT 
          BX5    X5+X2       MAKE INTO SHORT CONSTANT 
          PL     X1,CUD7     IF NOT ADJUSTABLY DIMENSIONED
          SA1    S=VD 
          CLAS=  X2,TP,(SHRT) 
          LX1    TP.ORDP
          BX5    -X2*X5      REMOVE TP.SHRT (LEAVING BIAS + MODE) 
          BX5    X1+X5       ORD + BIAS + MODE = VD. PRODUCT OF SPANS 
          EQ     CUD7 
  
 CUD4     ZR     B2,CUD7     IF NOT CONSTANT
          RJ     UDP         UNIT DESIGNATOR PROCESSING 
  
 CUD7     RJ     OUT         OUTPUT UNIT TURPLE 
          EQ     EXIT.
  
 CUD9     SA4    S=BU 
          FATAL  B7 
          LX4    TP.ORDP
          ERRNZ  M.BOOL 
          EQ     CUD7 
  
 CUDA     BSS    2
 ICK      SPACE  4,10 
**        ICK -  I/O CONTROL KEYWORD CHECK
* 
*         ENTRY  (B4) _ SUPPOSED KEYWORD TOKEN
*                (B6) = FWA OF KEYWORD TABLE TO SEARCH
*                (B7) = LENGTH OF KEYWORD TABLE 
* 
*         EXIT   (B7) = KEYWORD TABLE ADDRESS IF KEYWORD
*                (B4) _ TOKEN FOLLOWING KEYWORD 
*                (X6) = KEYWORD TABLE ENTRY 
* 
*                (B7) = 0 IF NOT KEYWORD
*                (B4) _ UNCHANGED 
* 
*         USES   A1,A2,A3,A4,A6,A7  B2,B7  X1,X2,X3,X4,X6,X7
  
  
 ICK      SUBR               ...ENTRY/EXIT... 
  
*         INITIALIZATION
  
          SA1    B4          THE SUPPOSED KEYWORD (1ST 7 CHARACTERS)
          =A2    A1+1        (2ND 7 CHARACTERS, IF PRESENT) 
          SB2    X1-O.VAR 
          NZ     B2,ICK6     IF NOT O.VAR, CANT BE KEYWORD
          MX4    7*CHAR 
          SA3    B6 
          BX6    X4*X1       FIRST 7 CHARACTERS 
          BX7    X7-X7
          SB2    X2-O.VAR 
          NZ     B2,ICK1     IF NOT ANOTHER O.VAR TOKEN 
          BX7    X4*X2
  
*         SET UP FOR DIAGNOSTICS.  (FILL.S FOR IMMEDIATE MESSAGES, ICKA 
*         FOR DELAYED MESSAGES.)
  
 ICK1     SA6    FILL.
          SA7    FILL.2 
          SA6    ICKA 
          SA7    A6+1 
  
*         SCAN KEYWORD TABLE
*                (A3) _ CURRENT KEYWORD ENTRY 
*                (X6) = 1ST 7 CHARACTERS OF KEYWORD (FROM T.TB) 
*                (X7) = 2ND 7 CHARACTERS OF KEYWORD (FROM T.TB) 
  
 ICK2     LX3    0-KW.KEYP
          SA2    X3 
          ERRNZ  18-KW.KEYL 
          =B7    B7-1        DECREMENT LOOP COUNTER 
          IX2    X2-X6
          ZR     X2,ICK3     IF A 7 CHARACTER MATCH 
          =A3    A3+1        FETCH NEXT TABLE ENTRY 
          NZ     B7,ICK2     IF MORE TABLE TO SEARCH
          EQ     EXIT.
  
*         HERE IF 7 CHARACTER MATCH 
  
 ICK3     LX3    KW.KEYP
          BX6    X3 
          LX3    -KW.LENP 
          MX4    -KW.LENL 
          BX4    -X4*X3 
          SB2    X4 
          SB3    7*CHAR 
          =A4    A2+1        SECOND 7 CHARACTERS
          IX7    X7-X4
          SB7    A3 
          LE     B2,B3,ICK5  IF KEYWORD HAS .LE. 7 CHARACTERS 
          ZR     X7,ICK4     IF KEYWORD MATCH ON ALL CHARACTERS 
          SB7    0           INDICATE NO MATCH
          EQ     EXIT.
  
ICK4      SB4    B4+1        PAST KEYWORD (2ND TOKEN) 
  
ICK5      SB4    B4+1        PASK KEYWORD (1ST TOKEN) 
          EQ     EXIT.
  
 ICK6     SA2    X1+CHARMAP 
          =B7    0           INDICATE NOT KEYWORD 
          MX4    TB.TOCL
          MX7    0           FILL.2 WILL BE NULL
          ERRNZ  TB.TOCL-CH.DPCL
          NZ     X2,ICK7     IF TOKEN FORCES STRING 
          LX2    X1          ELSE USE TOKEN BUFFER STRING 
  
 ICK7     BX6    X4*X2       EXTRACT STRING FOR FILL. 
          SA6    FILL.
          =A7    A6+1 
          EQ     EXIT.
  
ICKA      BSS    2           KEYWORD (DPC) FOR DELAYED DIAGNOSTICS
 IIC      SPACE  4,10 
**        IIC - INITIALIZE I/O CONTROL
* 
*         INITIALIZES I/O CONTROL CELLS AND SOME PARSER CONTROL CELLS.
* 
*         ENTRY  (B6) = DIRECTION INDICATOR.
* 
*         EXIT   (B6) = PRESERVED 
*                (IODIR)   = (B6) FOR TESTING I/O DIRECTION.
*                (IOSKP)   = 0 FOR NO SKIP TAG
*                (IOARGT)  = S=DIR FOR SETTING (ARGMODE) LATER. 
*                (IOREF)   = CR.DIR FOR X-REF.
*                (ARGCOMA) = 0 FOR PARSING OPERATIONS.
*                (LISTDIR) = 0, NOT LIST-DIRECTED (TP.IOD VICE IOP).
* 
*         USES   A1,A6,A7  X1,X6,X7 
  
  
 IIC      SUBR               ENTRY/EXIT...
          SA1    IOARGM 
          NZ     B6,IIC1     IF OUTPUT DIRECTION
          =A1    A1+1 
 IIC1     SX7    B6 
          SA7    IODIR
          BX6    X1 
          AX1    AM.REFP
          =A6    A7-IODIR+IOARGT
          BX7    X1 
          =A7    A6-IOARGT+IOREF
          SX6    0
          SA6    ARGCOMA
          SA6    LISTDIR
          SA6    IOSKP
          ERRNZ  PM=EXPR     (NEEDS SX6)
          SA6    CVLPM
          EQ     EXIT.
 IOJ      SPACE  4,10 
**        IOJ -  COMPILE JUMP TO I/O ROUTINE. 
* 
*         IF NOT PROCESSING LIST FOR *DATA*,
*         ADDS A V=IOSUB TURPLE TO T.PAR (WHEN NECESSARY).
*         MOVES THE CONTENTS OF T.ARG TO T.PAR
* 
*         ENTRY  (X6) = TERMINATION CODE -- 
*                        1 = INTERRUPTION OF LIST.  NOTHING COMPILED IF 
*                            (IOLEN) = 0. 
*                        0 = TERMINAL CALL.  MUST BE COMPILED.
*                (IONAM) = I/O ROUTINE ORDINAL (RELATIVE TO S.IOCALL).
*                          IF THE INITIAL CALL HAS NOT BEEN COMPILED, 
*                          THE ORDINAL IS COMPLEMENTED. 
*                (CVLPM) = CALLER'S PARSE MODE. 
* 
*         EXIT   (CURST) = RESET TO (T=PAR) 
* 
*         USES   ALL BUT  A0  B4
* 
*         CALLS  EMT, FAT, MFP, TSX 
  
  
 IOJ      SUBR   =           ENTRY/EXIT...
          SA1    CVLPM
          SA5    T=IOARG
          NZ     X1,EXIT.    IF FUNNY PARSING MODE
          ERRNZ  PM=EXPR
          ZR     X6,IOJ1     IF TERMINAL CALL, MUST COMPILE 
          ZR     X5,EXIT.    IF EMPTY LIST, IGNORE..
 IOJ1     SA6    IOJA        SAVE TERMINATION CODE
          ZR     X5,IOJ2     IF NO AP TURPLES 
          BX4    0           INDICATE RETAIN NO TURPLES 
          CALL   FAT         FLUSH APLIST TURPLES 
**        CALL   MFP         (WAS) MARK FIRST PARAMETERS
 IOJ2     SA5    IOJA        TERMINATION CODE 
          LX5    TP.BIASP    INDICATE CALL STATUS 
          SA3    IONAM
          PL     X3,IOJ4     IF NOT INITIAL CALL
          BX3    -X3
          =X6    X3+S=CONT   RESET ROUTINE NAME TO CONTINUATION TYPE
          SA6    A3 
 IOJ4     TAGSEX X3+S.IOCALL
          BX4    X6          SAVE ROUTINE TAG 
  
*         (X4) = (1OP) = I/O ROUTINE (TP. FORMAT) 
*         (X5) = (2OP) = RESTART INDICATOR
  
          EMIT   V=IOSUB
  
*         EMIT LIST COLLAPSE CONTROL VARIABLE DEFINITIONS.
  
          SA5    =XT=IOLC 
          SA1    DATFLG 
          NZ     X1,IOJ5     IF *DATA*
          ZR     X5,IOJ5     IF NO COLLAPSE *CV* DEFINITIONS
          ALLOC  T.PAR,X5 
          SHRINK T=IOLC 
          SX0    B7          LWA1 OF T.PAR
          SA2    =XT.IOLC    SOURCE OF TURPLES
          IX3    X0-X5       DESTINATION
          BX1    X5          NUMBER OF WORDS TO MOVE
          MOVE   X1,X2,X3    MOVE TURPLES TO T.PAR
  
 IOJ5     SA1    T=PAR
          LX6    X1 
          SA6    CURST
          SHRINK T=ILI
          EQ     EXIT.
  
 IOJA     BSS    1           TERMINATION CODE SAVE
 OUT      SPACE  4,10 
**        OUT - OUTPUT UNIT DESIGNATOR TURPLE.
* 
*         ENTRY  (X4) = UNIT DESIGNATOR (TP. FORMAT)
*                (X5) = UNIT DESIGNATOR SIZE (TP. FORMAT) 
* 
*         EXIT   (B2) = S=INF IF INTERNAL FILE, ELSE 0. 
*                UNIT DESIGNATOR TURPLE OUTPUT. 
* 
*         USES   X - ALL  A - 1,2,3,4,6,7  B - 2,3,7. 
* 
*         CALLS  EMT,MVE=.
  
  
 OUT      SUBR               ENTRY/EXIT...
          SA1    IOUNT       FETCH PROTOTYPE
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX0    -X0*X4      EXTRACT MODE OF UNIT DESIGNATOR
          LX4    TP.MODEP 
          LX0    SP.MODEP 
          BX6    X1+X0       MERGE IN MODE
          SA6    CUDA 
          SHRINK T=SCR
          EMIT   CUDA,*,T.SCR 
          BX5    X4          PRESERVE ACROSS MOVE 
          SX1    Z=TURP      LENGTH 
          SA2    T.SCR       SOURCE 
          SA3    T.IOARG     DESTINATION
          MOVE   X1,X2,X3    UNIT DESIGNATOR MUST BE FIRST I/O CONTROL
          SHRINK T=SCR
          =B2    0
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5      EXTRACT MODE OF UNIT DESIGNATOR
          SB7    X0-M.CHAR
          NZ     B7,EXIT.    IF NOT INTERNAL FILE 
          SB2    S=INF
          EQ     EXIT.
 PFN      SPACE  4,10 
**        PFN -  PROCESS FORMAT/NAMELIST DESIGNATOR 
*                ALSO PROCESSES LIST DIRECTED I/O INDICATOR (*) 
* 
*         ENTRY  (B4) _ FORMAT DESIGNATOR 
*                (B6) = S=INP OR S=OUT
* 
*         EXIT   (B4) _ LAST TOKEN OF FORMAT DESIGNATOR IN *TB* 
*                (B6) =  RESET WITH PROPER S=CODE INDICATOR 
*                FORMAT/NAMELIST CONTROL TURPLE OUTPUT, AS NEEDED 
* 
*         USES   ALL EXCEPT A0
* 
*         CALLS  CT1, ISL, OCT, PAR, SSY, TPC 
  
  
 PFN      SUBR               ...ENTRY/EXIT... 
          SA1    B4+
          SA2    LISTDIR
          SB2    X1-O.STAR
          NZ     B2,PFN1     IF NOT LIST DIRECTED I/O 
          =X6    1
          SA6    A2          SET LIST DIRECTED FLAG 
          SB6    B6+S=FREE
          SA1    PKCA 
          SA2    IODIR
          =X7    1
          LX7    59-IC.UNT
          BX1    X1*X7
          SX7    B6 
          ZR     X1,EXIT.    IF UNIT NOT SPECIFIED
          IX2    X7-X2       REMOVE I/O DIRECTION 
          SX2    X2-S=FREE-S=INF
          NZ     X2,EXIT.    IF NOT INTERNAL FILE 
          FATAL  E.IO26      **INTERNAL FILE CANT BE FREE FORMAT
          EQ     EXIT.
  
  
 PFN1     SA3    IOREF
          MX7    0
          BX6    X3 
          SA7    A2          INDICATE FORMATTED, NOT LIST DIRECTED I/O
          SA6    REFNUM 
          SA7    NRF         NAMELIST CROSS REF FLAG
          ZR     X1,E.IO07   IF *EOS* -- ERROR
          SX2    X1 
          ERRNZ  18-TB.TOTL+0-TB.TOTP 
          BX6    X1-X2
          SB7    X1-O.CONS
          NZ     B7,PFN2     IF NO FORMAT LABEL 
          CLAS=  X2,WB,(FREF) 
          CALL   ISL         IDENTIFY STATEMENT LABEL 
          SB6    B6+S=COD 
          SX4    IC.FMT 
          EQ     PFN9 
  
  
**        HERE IF NON-NUMERIC.  WILL BE VARIABLE FORMAT OR NAMELIST.
  
 PFN2     SB7    X1-O.CHAR
          ZR     B7,PFN3     IF CHARACTER CONSTANT
          SX6    X1-O.LP
          SA6    PFNPFE      SET *PARENTHESIZED FMT EXPR* FLAG PROPERLY 
          ZR     X6,PFN3     IF PARENTHESIZED FORMAT EXPRESSION 
          SB7    X1-O.VAR 
          NZ     B7,E.IO07   IF NOT VARIABLE EITHER 
          MX6    WA.SYML
          BX6    X6*X1       SYMBOL ONLY
          CALL   SSY
          MI     B7,PFN3     IF NOT IN SYMTAB, NOT NAMELIST 
          SBIT   X2,WB.NLSTP
          MI     X2,PFN5     IF NAMELIST
  
**        PROCESS VARIABLE OR ASSIGNED FORMATS
  
 PFN3     SX6    B6 
          SB6    B6+S=COD 
          SA2    IOREF
          SA1    FMTARM 
          SX7    55B
          BX2    X7-X2
          LX2    AM.REFP
          BX7    X1-X2
          SA7    ARGMODE
          SX7    O.SLP
          SA6    IONAM       SAVE (B6)
          =A7    B4-1 
          =B4    B4-1 
          CALL   PAR         PARSE THE FORMAT DESIGNATOR
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
          SA2    IONAM
          SB6    X2          RESTORE (B6) 
          EQ     EXIT.
  
**        PROCESS NAMELIST NAME.
  
 PFN5     CALL   CT1         GET TP. FORMAT 
          SA1    WO.LOR 
          PL     X1,PFN7     IF NO CROSS REFERENCE SELECTED 
          SA4    IODIR
          SX1    CR.OUT 
          NZ     X4,PFN6     IF OUTPUT DIRECTION
          SX1    CR.INP 
  
 PFN6     LX1    XR.TAGL
          BX7    X1+X0
          SA7    NRF         24/0,18/IO DIRECTION,18/SYMTAB ORDINAL 
  
 PFN7     CLAS=  X0,WB,(MAT)
          BX7    X0+X2       MERGE IN MATERIALIZE BIT 
          SA7    A2          UPDATE *WB*
          SA1    PKCA        CONTROL ITEM SPECIFIED FLAG
          =X7    1
          LX7    59-IC.NML
          BX7    X7+X1       MERGE IN NAMELIST BIT
          SA7    A1 
          SA1    IODIR
          =X2    1
          LX2    59-IC.UNT
          BX2    X7*X2
          SX7    B6 
          ZR     X2,PFN8     IF UNIT NOT SPECIFIED
          IX2    X7-X1
          SX2    X2-S=INF 
          NZ     X2,PFN8     IF NOT INTERNAL FILE 
          FATAL  E.IO33 
  
 PFN8     SB6    B6+S=NLST
          SX4    IC.NML 
          NZ     X1,PFN9     IF OUTPUT DIRECTION
          CLAS=  X2,TP,(IOD,IOP)
          BX6    X6+X2       FLAG POTENTIAL DEFINITION
  
**        OUTPUT FORMAT/NAMELIST CONTROL TURPLE.
  
 PFN9     BX5    X6 
          RJ     OCT         OUTPUT CONTROL TURPLE
          SA2    NRF
          ZR     X2,EXIT.    IF NO CROSS REFERENCE SELECTED 
          SX6    X2          X6 = SYMTAB ORDINAL
          AX2    XR.TAGL
          SX1    X2          X1 = IO DIRECTION
          LX6    XR.TAGP     XREF TAG 
          ADDREF X6,X1
          EQ     EXIT.
  
 PFNPFE   CON    1           0 IFF FORMAT EXPRESSION IS PARENTHESIZED 
 NRF      CON    0           24/0,18/IO DIRECTION,18/SYMTAB ORDINAL 
 PKC      SPACE  4,10 
**        PKC -  PROCESS KEYWORD CONTROL ITEMS
* 
*         ENTRY  (X1) = KEYWORD LEGALITY
*                (B4) _ FIRST CONTROL KEYWORD 
*                (B6) = (S=COD) INDICATOR 
*                (PKCA) = BIT MASK OF DEFINED CONTROL ITEMS 
* 
*         EXIT   (B4) _ CLOSING *)* 
*                (X3) = I/O CONTROL DEFINED MASK (PKCA) 
* 
*         CALLS  CUD, EMT, ICK, ISL, OCT, PAR, PFN, TPC 
  
  
 PKCA     BSS    1           CONTROL ITEM DEFINED MASK
 PKCB     BSS    1           S=INDICATOR SAVE 
 PKCC     BSS    1           LEGALITY MASK
 PKCD     BSS    1           IC. CONTROL CODE SAVE
  
 PKC      SUBR               ...ENTRY/EXIT... 
          LX7    X1 
          SA7    PKCC 
          SX6    B6 
          =A6    A7-PKCC+PKCB 
  
 PKC1     SB6    FW.CTL 
          SB7    L.CTL
          RJ     ICK         CHECK FOR I/O CONTROL KEYWORD
          ZR     B7,E.IO10   IF NOT KEYWORD 
          SA1    B4+
          SB2    X1-O.= 
          NZ     B2,E.IO16   IF NOT *=* 
          HX6    KW.INFO
          AX6    -KW.INFOL   EXTRACT KEYWORD JUMP ADDRESS 
          SB2    X6 
          SA1    PKCC        LEGALITY MASK
          SB7    B7-FW.CTL+1 CONVERT TABLE ADDRESS TO ORDINAL 
          LX1    X1,B7
          PL     X1,E.IO11   IF KEYWORD NOT LEGAL 
          SA1    PKCA        ALREADY DEFINED MASK 
          SB3    59 
          =X6    1
          SB3    B3-B7
          LX6    B3 
          BX0    X1*X6
          NZ     X0,E.IO12   IF ALREADY DEFINED 
          BX6    X1+X6       ADD IN THIS DEFINITION BIT 
          SA6    A1 
          SX6    B7 
          SA6    PKCD        SAVE THE CONTROL CODE
          =A1    B4+1 
          =B4    B4+1        SKIP THE *=* 
          JP     B2          PROCESS THE KEYWORD PARAMETER
  
 PKC=     EQ     "BLOWUP"    FOR UNUSED CODES 
  
 PKC=DIR  BSS    0
 PKC=FMD  BSS    0
 PKC=NAM  BSS    0
 PKC=SEQ  BSS    0
 PKC=UNF  BSS    0
 PKC10    SA1    ICCARM      MUST BE CHARACTER VARIABLE OR ARRAY ELEMENT
          EQ     PKC14       CONTINUE PROCESSING
  
 PKC=ACC  BSS    0
 PKC=BLK  BSS    0
 PKC=FOR  BSS    0
          SA1    PKCB        STATEMENT INDICATOR
          SB2    S.INQUI
          SB2    -B2
          SX1    X1+B2
          ZR     X1,PKC10    IF INQUIRE, PARAMETER MUST BE VARIABLE 
 PKC=STA  BSS    0
          SA1    ICCXARM     MUST BE CHARACTER EXPRESSION 
          EQ     PKC14       CONTINUE PROCESSING
  
 PKC=RCL  BSS    0
          SA1    PKCB        STATEMENT INDICATOR
          SB2    S.INQUI
          SB2    -B2
          SX1    X1+B2
          NZ     X1,PKC12    IF NOT INQUIRE 
 PKC=IOS  BSS    0
 PKC=NXT  BSS    0
 PKC=NUM  BSS    0
          SA1    ICIARM      MUST BE INTEGER VARIABLE OR ARRAY ELEMENT
          EQ     PKC14       CONTINUE PROCESSING
  
 PKC=BFL  BSS    0
          ANSI   E.IO22 
 PKC=REC  BSS    0
 PKC12    SA1    ICIXARM     MUST BE POSITIVE INTEGER EXPRESSION
          EQ     PKC14       CONTINUE PROCESSING
  
 PKC=EXS  BSS    0
 PKC=NMD  BSS    0
 PKC=OPE  BSS    0
          SA1    ICLARM      MUST BE LOGICAL VARIABLE OR ARRAY ELEMENT
          EQ     PKC14       CONTINUE PROCESSING
  
 PKC=END  BSS    0
 PKC=ERR  BSS    0
          SB2    X1-O.CONS
          NZ     B2,E.IO15   IF NOT STATEMENT LABEL 
          CLAS=  X2,WB,(GOTO,SREF)
          LX6    X1 
          CALL   ISL         IDENTIFY THE STATEMENT LABEL 
          MI     X6,PSL      IF ERROR IN STATEMENT LABEL
          BX5    X6 
          EQ     PKC15       FINISH PROCESSING
  
 PKC=FIL  BSS    0
          SA1    ICCXARM     MUST BE CHARACTER EXPRESSION 
          SX7    O.SLP
          =A7    B4-1        SET FOR PAR
          =B4    B4-1 
          LX6    X1 
          SA6    ARGMODE
          CALL   PAR
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
          SA1    PKCB        STATEMENT INDICATOR
          SB2    S.INQUI
          SB2    -B2
          SX1    X1+B2
          NZ     X1,PKC15    IF NOT INQUIRE, PROCESS NORMALLY 
          SA1    IOCTL       FETCH PROTOTYPE
          SA4    PKCD        I/O CONTROL CODE 
          SX6    M.CHAR 
          LX6    SP.MODEP 
          BX6    X1+X6       MERGE IN MODE
          SA6    OCTA 
          SHRINK T=SCR
          LX4    TP.IOCP
          MX6    1
          SA6    CUDA+1      FLAG FOR SFP 
          EMIT   OCTA,*,T.SCR 
          SX1    Z=TURP      LENGTH 
          SA2    T.SCR       SOURCE 
          SA3    T.IOARG     DESTINATION
          MOVE   X1,X2,X3    FOR INQUIRE, FILE SPECIFIER MUST BE FIRST
          SHRINK T=SCR
          EQ     PKC16       CONTINUE PROCESSING
  
 PKC=FMT  BSS    0
          SA1    PKCB 
          SB6    X1          PFN NEEDS (B6) = S=CODE INDICATOR
          RJ     PFN         PROCESS THE FORMAT DESIGNATOR
          SX6    B6 
          SA6    PKCB        SAVE (B6)
          EQ     PKC16       FINISH PROCESSING
  
 PKC=UNT  BSS    0
          RJ     CUD         COMPILE THE UNIT DESIGNATOR
          SA1    PKCB 
          SX6    X1+B2       ADJUST IF INTERNAL FILE
          SA6    A1 
          EQ     PKC16       FINISH PROCESSING
  
**        CALL PAR TO PROCESS THE KEYWORD PARAMETER 
*                (X1) = ARGMODE VALUE 
  
 PKC14    SX7    O.SLP
          =A7    B4-1        SET FOR PAR
          =B4    B4-1 
          LX6    X1 
          SA6    ARGMODE
          CALL   PAR         PARSE THE KEYWORD PARAMETER
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
  
**        FINISH PROCESSING INDIVIDUAL CONTROL KEYWORDS 
*                (X5) = I/O CONTROL PARAMETER (TP. FORMAT)
  
 PKC15    SA4    PKCD        I/O CONTROL CODE 
          RJ     OCT         OUTPUT CONTROL TURPLE
 PKC16    =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.COMMA 
          SB3    X1-O.RP
          ZR     B3,PKC20    IF *)*, FINISHED 
          NZ     B2,E.IO16   IF NOT *,*, ERROR
          =B4    B4+1        NEXT KEYWORD 
          EQ     PKC1        CONTINUE PROCESSING
  
 PKC20    SA2    PKCB 
          SB6    X2          RESTORE (B6) = S=CODE
          =A3    A2-PKCB+PKCA 
          SB2    S.INQUI
          SB2    B6-B2
          =X0    1
          LX0    59-IC.UNT
          ZR     B2,PKC25    IF INQUIRE 
          BX0    X3*X0
          ZR     X0,E.IO01   IF NO UNIT DESIGNATOR
          EQ     EXIT.
  
 PKC25    SX1    1
          LX1    59-IC.FIL
          BX0    X0+X1
          BX1    X3*X0
          BX0    X1-X0
          ZR     X1,E.IO20   IF NEITHER UNIT NOR FILE SPECIFIED 
          ZR     X0,E.IO21   IF BOTH UNIT AND FILE SPECIFIED
          EQ     EXIT.
 SFP      SPACE  4,10 
**        SFP -  SET FILE PROPERTY BITS 
* 
*         THIS ROUTINE WILL SET BITS IN *WC* ENTRY
*         FOR A FILE SO THAT THE I/O REFMAP CAN BE OUTPUT.
* 
*         ENTRY  (X3) = 1 IF BUFFER IN/OUT STMT 
*                     = CONTENTS OF PKCA OTHERWISE. 
* 
*                (CUDA+1) = MI IF SUPPRESS PROPERTIES 
*                         = SYMTAB *WB* INDEX OF FILE OTHERWISE.
* 
*         USES   X - 0,1,2,4,6  A - 1,2,4,6  B - 2
  
 SFP      SUBR               ...ENTRY/EXIT... 
          SA1    WO.LOA 
          SA2    WO.LOM 
          SA4    WO.LOR 
          BX1    X1+X2
          BX1    X1+X4
          ZR     X1,EXIT.    IF REFMAP NOT SELECTED 
          =A1    CUDA+1      X1 = *WB* INDEX OF FILE
          MI     X1,EXIT.    IF SUPPRESSION DESIRED 
          =B2    X1 
          MX6    0
          SA1    T.SYM
          SA4    IODIR
          PL     X4,SFP30    IF NOT AUXILLARY I/O STMT
          LDBIT  X2,WB.AUXP 
          BX6    X2+X6
          BX0    X3 
          LX0    -1 
          PL     X0,SFP60    IF NOT BUFFER IN/OUT STMT
          SX0    145B 
          LX0    WB.FMTP-6
          BX6    X6-X0       INDICATE BINARY, SEQUENTIAL FILE 
          EQ     SFP60
  
 SFP30    LDBIT  X2,WB.SEQP 
          =X0    1
          LX0    59-IC.REC
          BX4    X0*X3
          ZR     X4,SFP40    IF SEQUENTIAL FILE 
          LX2    -WB.SEQP+WB.DIRP 
  
 SFP40    BX6    X6+X2
          LX0    IC.REC-IC.FMT
          BX4    X0*X3
          LDBIT  X2,WB.FMTP 
          NZ     X4,SFP50    IF FORMATTED FILE
          LX2    -WB.FMTP+WB.BINP 
  
 SFP50    BX6    X6+X2
  
 SFP60    SA1    X1+B2       *WB* OF FILE 
          BX6    X6+X1       MERGE WITH PROPERTY BITS 
          SA6    A1          UPDATE *WB*
          EQ     EXIT.
 UDP      SPACE  4,10 
**        UDP - UNIT DESIGNATOR PROCESSING. 
* 
*         ENTRY  (X6) = BINARY OF UNIT DESIGNATOR.
* 
*         EXIT   IF UNIT IS OK
* 
*                (CUDA+1) = SYMTAB *WB* INDEX OF FILE NAME. 
*                FILE NAME TAPENNN IS IN SYMBOL TABLE, WITH 
*                APPROPRIATE FIELDS FILLED IN. (NNN IS DPC OF UNIT) 
* 
*                IF UNIT IS BAD - 
* 
*                (X4) = TP. OPERAND FOR BAD UNIT (S=BU) 
*                DIAGNOSTIC ISSUED. 
* 
*         USES   X - 0,1,2,3,6,7  A - 1,2,3,4,5,6,7  B - 2,3,7. 
* 
*         CALLS  VUD,CDD,SSY,ESY,ERT. 
  
  
 UDP      SUBR               ENTRY/EXIT...
          SB7    E.IO03      UNIT NUMBER OUTSIDE RANGE 0-100
          MI     X6,UDP30    ** IF UNIT DESIGNATOR TOO SMALL
          RJ     VUD         VALIDATE THE UNIT DESIGNATOR 
          ZR     B7,UDP10    IF LEGAL FILE NAME 
          PL     B7,UDP30    IF ILLEGAL FILE NAME 
          SX1    1000 
          IX1    X6-X1
          SB7    E.IO03      ** UNIT NUMBER TOO LARGE 
          PL     X1,UDP30    IF UNIT MORE THAN THREE DIGITS 
          BX1    X6 
          BX6    X4 
          SA6    UDPA        SAVE X4
          BX6    X5 
          =A6    A6+1        SAVE X5
          SX5    B4          SAVE B4
          CALL   CDD         CONVERT TO DPC 
          MX6    1
          =B2    B2-1 
          AX6    B2,X6
          SA1    =4LTAPE
          BX4    X6*X4       ERASE SUPERFLUOUS CHARS
          LX4    -4*CHAR
          BX6    X4+X1       APPEND TO TAPE 
          SA4    UDPA        RESTORE X4 
          SB4    X5          RESTORE B4 
          =A5    A4+1        RESTORE X5 
  
 UDP10    MX1    1
          BX6    X6+X1       SET BIT 59 ON FILE NAME
          CALL   SSY         FIND WHERE TO PUT FILE 
          PL     B7,UDP20    IF *HIT* 
          MX7    0
          MX2    0
          ADSYM  T.SYM       ADD FILE TO SYMTAB 
  
 UDP20    SX6    B7 
          =A6    CUDA+1      SET *WB* INDEX EXIT CONDITION
          CLAS=  X2,WB,(NVAR,UDC,CGS) 
          SA1    X1+B7       *WB* 
          BX6    X1+X2       MERGE ABOVE BITS 
          SA6    A1          UPDATE *WB*
          LX0    XR.TAGP
          SA1    IOREF
          ADDREF X0,X1       ISSUE REFERENCE
          EQ     EXIT.
  
**        HERE IF UNIT DESIGNATOR IS BAD. 
  
 UDP30    SA4    S=BU 
          FATAL  B7 
          LX4    TP.ORDP
          ERRNZ  M.BOOL 
          EQ     EXIT.
  
 UDPA     EQU    CUDA 
 VUD      SPACE  4,10 
**        VUD -  VALIDATE UNIT DESIGNATOR.
* 
*         ENTRY  (X6) = POSSIBLE CONSTANT UNIT DESIGNATOR.
* 
*         EXIT   (B7) = ZR IF DESIGNATOR IS LEGAL FILE NAME.
*                     = ERROR ADDRS IF DESIGNATOR IS ILLEGAL FILE NAME. 
*                     = MI IF DESIGNATOR IS A NUMBER. 
* 
*         USES   X - 0,7  B - 7 
  
 VUD      SUBR               ENTRY/EXIT...
          =B7    -1 
          MX0    7*CHAR 
          BX0    X0*X6
          ZR     X0,EXIT.    IF NOT BOOLEAN FILE NAME 
          MX0    CHAR 
          BX0    X0*X6
          LX0    CHAR 
          SX7    X0-1RA 
          SB7    E.IO31      ** NOT LEGAL FILE NAME 
          MI     X7,EXIT.    IF ILLEGAL FILE NAME 
          SX7    X0-1RZ 
          =X7    X7-1 
          PL     X7,EXIT.    IF ILLEGAL FILE NAME 
          MX0    7*CHAR 
          BX0    -X0*X6 
          SB7    E.IO32      ** FILE NAME GT 7 CHARS
          NZ     X0,EXIT.    IF FILE NAME GT 7 CHARS
          =B7    0
          EQ     EXIT.
          TITLE  PARSER INTERFACE ROUTINES. 
 A=BMOD   SPACE  4,10 
**        A=BMOD - CHECK BUFFER IN/OUT MODE DESIGNATOR. 
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         CALLS  LCT, OCT 
  
  
 A=BMOD   BSSENT 0           ENTRY... 
          BX1    X5 
          CALL   LCT         TEST FOR CONSTANT
          SB3    X0-M.INT 
          NZ     B3,E.IOB2   IF NOT INTEGER 
          ZR     B2,BMOD1    IF NOT CONSTANT
          ZR     X6,BMOD1    IF CONSTANT *0*
          =X0    1
          IX6    X6-X0
          ZR     X6,BMOD1    IF CONSTANT *1*
          EQ     E.IOB8 
  
 BMOD1    LX0    X5 
          SBIT   X0,TP.INTRP
          MI     X0,E.IOB2   IF EXPRESSION
          SX4    IC.MOD 
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 A=BLWA   SPACE  4,10 
**        A=BLWA - CHECK BUFFER IN/OUT LAST WORD ADDRESS. 
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         CALLS  OCT, VAI 
  
  
 A=BLWA   BSSENT 0           ENTRY... 
          SA4    IODIR
          SB3    E.IOB7      ** BUFFER ADDRESS CANNOT BE CONST/EXPR 
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          MI     B3,BUFERR   IF NOT ADDRESSABLE 
          SB2    X0-M.CHAR
          ZR     B2,E.IOB0   IF TYPE CHARACTER
          CALL   BBC         CONVERT TO BASE/BIAS FORMAT
          SB3    X0-M.DBL 
          BX7    X5 
          LX2    X5 
          SA7    IOBLWA 
          SA3    T.PAR
          HX7    TP.BIAS
          AX7    -TP.BIASL   POSITION FOR LATER USE 
          CLAS=  X0,TP,(INTR) 
          BX0    X0*X2
          LX2    -TP.ORDP 
          ZR     X0,BLWA3    IF NOT ARRAY LOAD
          MX0    -TP.ORDL 
          BX2    -X0*X2      ISOLATE ORDINAL (T.PAR)
          =B2    X2+OR.1OP
          SA2    X3+B2       FETCH ARRAY OPERAND
          BX0    X2 
          LX2    -TP.ORDP 
          MI     B3,BLWA4    IF NOT DOUBLE OR COMPLEX 
          HX0    TP.BIAS
          AX0    -TP.BIASL   EXTRACT (SIGN EXTEND) BIAS 
          =X1    1
          IX0    X0+X1       INCREMENT FOR DOUBLE WORD ELEMENT
          BX1    X2 
          LX1    TP.ORDP
          MX7    -TP.BIASL
          BX0    -X7*X0      EXTRACT NEW BIAS 
          LX0    TP.BIASP 
          LX7    TP.BIASP 
          BX1    X7*X1       REMOVE OLD BIAS
          BX7    X1+X0       INSERT NEW BIAS
          SA7    A2          UPDATE PARSE FILE
          EQ     BLWA4
  
 BLWA3    MI     B3,BLWA4    IF NOT DOUBLE OR COMPLEX 
          =X1    1
          LX1    TP.BIASP 
          IX5    X5+X1       INCREMENT FOR DOUBLE WORD ITEM 
          BX7    X5 
          SA7    IOBLWA 
  
 BLWA4    SA1    IOBFWA 
          BX6    X1 
          HX6    TP.BIAS     LEFT JUSTIFY BIAS
          AX6    -TP.BIASL   POSITION FOR LATER USE 
          LX4    X1          FWA (ACTUAL OPERAND) 
          CLAS=  X0,TP,(INTR) 
          BX0    X0*X1
          LX1    -TP.ORDP 
          ZR     X0,BLWA5    IF NOT ARRAY LOAD
          MX0    -TP.ORDL 
          BX1    -X0*X1      ISOLATE ORDINAL (T.PAR)
          =B2    X1+OR.1OP
          SA1    X3+B2       FETCH ARRAY OPERAND
          LX1    -TP.ORDP 
  
 BLWA5    MX3    -TP.ORDL 
          BX0    -X3*X2 
          BX3    -X3*X1 
          SB3    X0          SET (B3) = SYMORD OF LWA 
          SB2    X3          SET (B2) = SYMORD OF FWA 
          BX3    X4+X5
          HX3    TP.INTR
          NE     B2,B3,BLWA10      IF NOT SAME SYMBOL 
          MI     X3,BLWA30   IF EITHER SUBSCRIPT NON-CONSTANT 
          EQ     BLWA28 
  
*         TEST FOR FWA AND LWA BOTH FORMAL PARAMETERS.
*                (X4) = OPERAND FOR FWA (TP. FORMAT)
*                (X5) = OPERAND FOR LWA (TP. FORMAT)
  
 BLWA10   BX0    X4-X5
          HX0    TP.FP
          MI     X0,E.IOB9   IF ONLY ONE IS A FORMAL PARAMETER
          BX3    X4+X5
          HX3    TP.FP
          MI     X3,BLWA30   IF BOTH ARE FORMAL PARAMETERS
  
*         TEST FOR FWA AND LWA IN SAME COMMON BLOCK 
*                (B2) = SYMORD OF FWA 
*                (B3) = SYMORD OF LWA 
  
          SA3    T.SYM
          SX1    B2+B2
          SX2    B3+B3
          =X3    X3+WB.W
          SB2    B2+X1       (B2) = INDEX OF FWA
          SB3    B3+X2       (B3) = INDEX OF LWA
          ERRNZ  3-Z=SYM
          SA1    X3+B2       (X1) = SYMTAB ENTRY OF FWA 
          SA2    X3+B3       (X2) = SYMTAB ENTRY OF LWA 
          BX0    X1-X2
          BX3    X1+X2
          SBIT   X0,WB.COMP 
          SBIT   X3,WB.COMP 
          MI     X0,E.IOB9   IF ONLY ONE IN COMMON
          PL     X3,BLWA20   IF NEITHER IN COMMON 
          =A1    A1-WB.W+WC.W 
          =A2    A2-WB.W+WC.W 
          MX0    -WC.RBL
          BX3    X1-X2       COMPARE BLOCK NUMBERS
          LX0    WC.RBP 
          BX0    -X0*X3 
          ZR     X0,BLWA26   IF IN SAME COMMON BLOCK
  
*         TEST FOR FWA AND LWA IN SAME EQUIVALENCE CLASS. 
*                (X1) = SYMTAB WORD WB OF FWA 
*                (X2) = SYMTAB WORD WB OF LWA 
  
 BLWA20   BX3    X1*X2
          SBIT   X3,WB.EQVP 
          PL     X3,E.IOB9   IF BOTH NOT EQUIVALENCED 
          HX1    WB.BASE
          HX2    WB.BASE
          AX1    -WB.BASEL   ISOLATE BASE MEMBER
          AX2    -WB.BASEL   ISOLATE BASE MEMBER
          IX0    X1-X2
          NZ     X0,E.IOB9   IF NOT IN SAME EQUIVALENCE CLASS 
          =A1    A1-WB.W+WC.W 
          =A2    A2-WB.W+WC.W 
  
  
*         FWA AND LWA ARE NOW KNOWN TO BE IN SAME STORAGE BLOCK (COMMON 
*         OR LOCAL-EQUIVALENCED).  IF SUBSCRIPTS ARE CONSTANT, CHECK
*         THAT(FWA .LE. LWA). 
*                (X1) = SYMTAB WORD WC OF FWA 
*                (X2) = SYMTAB WORD WC OF LWA 
  
 BLWA26   BX3    X4+X5
          HX3    TP.INTR
          MI     X3,BLWA30   IF EITHER SUBSCRIPT NON-CONSTANT 
          MX3    -WC.RAL
          LX1    -WC.RAP
          LX2    -WC.RAP
          BX1    -X3*X1      RELATIVE BIAS OF FWA 
          BX2    -X3*X2      RELATIVE BIAS OF LWA 
          IX6    X1+X6       TOTAL BIAS OF FWA
          IX7    X2+X7       TOTAL BIAS OF LWA
  
 BLWA28   IX0    X7-X6
          MI     X0,E.IOB6   IF LWA .LT. FWA
  
 BLWA     BSSENT 0           ...DIAGNOSTIC RETURN 
  
 BLWA30   SX4    IC.BUF 
          SA5    IOBLWA 
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 C=BFWA   SPACE  4,10 
**        C=BFWA - CHECK BUFFER IN/OUT FIRST WORD ADDRESS.
* 
*         EXIT   CONTROL TURPLE OUTPUT
*                (IOBFWA) = BUFFER I/O FIRST WORD ADDRESS 
* 
*         CALLS  OCT, VAI 
  
  
 C=BFWA   BSSENT 0           ENTRY... 
          SA4    IODIR
          SB3    E.IOB7      ** BUFFER ADDRESS CANNOT BE CONST/EXPR 
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          MI     B3,BUFERR   IF NOT ADDRESSABLE 
          SB2    X0-M.CHAR
          ZR     B2,E.IOB0   IF TYPE CHARACTER
          CALL   BBC         CONVERT TO BASE/BIAS FORMAT
          SX4    IC.BUF 
          LX6    X5 
          SA6    IOBFWA 
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 C=CNT    SPACE  4,10 
**        C=CNT - CHECK XXCODE *COUNT* INDICATOR. 
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         CALLS  OCT
  
  
 C=CNT    BSSENT 0           ENTRY... 
          BX0    X5 
          SBIT   X0,TP.INTRP
          MI     X0,E.IOS9   IF EXPRESSION
          MX0    -TP.MODEL
          BX0    -X0*X5      EXTRACT MODE 
          ZR     X0,CNT1     IF BOOLEAN, OKAY 
          SX0    X0-M.INT 
          NZ     X0,E.IOS9   IF NOT INTEGER 
 CNT1     SX4    IC.CNT 
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 C=FMT    SPACE  4,10 
**        C=FMT - CHECK FORMAT VALIDITY.
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         CALLS  LCH, OCT 
  
  
 A=FMT    BSSENT 0           ENTRY... 
          =B4    B4-1        AJUST FOR FURTHER PROCESSING 
 C=FMT    BSSENT 0           ENTRY... 
          LX1    X5 
          CALL   LCH         TEST FOR CONSTANT
          SX4    IC.FMT 
          SB3    X0-M.CHAR
          NZ     B3,FMT10    IF NOT TYPE CHARACTER
          BX1    X5 
          SBIT   X1,TP.AREP 
          MI     X1,FMT30    IF ENTIRE ARRAY
          LX1    TP.AREL+TP.AREP
          CALL   GOL
          =A5    B6-1        RESTORE X5 
          SX4    IC.FMT      RESTORE X4 
          SX6    X7-2 
          BX6    -X6+X7 
          MI     X6,FMT30    IF LENGTH IS OKAY
          FATAL  E.IO36      ** LENGTH OF FORMAT MUST BE GREATER THAN 1 
          EQ     FMT30
  
 FMT10    SA1    PFNPFE 
          ZR     X1,E.IOF    IF NON-CHAR PARENTHESIZED EXPR 
          NZ     B2,E.IOF    IF NON CHARACTER CONSTANT
          BX1    X5 
          SBIT   X1,TP.INTRP
          MI     X1,E.IOF    IF NON CHARACTER EXPRESSION
          SBIT   X1,TP.ARRP/TP.INTRP
          PL     X1,FMT20    IF NOT ARRAY 
          SBIT   X1,TP.AREP/TP.ARRP 
          PL     X1,E.IOF    IF ARRAY ELEMENT (A(1)) REFERENCE
          ANSI   E.IOF1      NON CHAR ARRAY FMT NON-ANSI
          EQ     FMT30
  
 FMT20    SB2    X0-M.INT 
          NZ     B2,E.IOF2   IF NOT INTEGER 
          SX4    IC.FMTA
  
 FMT30    RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 A=FOU    SPACE  4,10 
**        A=FOU - DETERMINE WHETHER EXPRESSION JUST PARSED IS 
**                A FORMAT OR A UNIT DESIGNATOR.
* 
*         ENTRY  (X5) = TP. OPERAND FOR EXPRESSION. 
* 
*         EXIT   TO *A=FMT* IF EXPRESSION IS TYPE CHARACTER.
*                TO *A=UNT* OTHERWISE.
* 
*         USES   X - 1. 
  
  
 C=FOU    BSSENT 0
          IFEQ   TEST,ON,1
          EQ     "BLOWUP"    *FOUARM* IMPLIES NO ZERO LEVEL COMMAS
  
 A=FOU    BSSENT 0           ENTRY... 
          MX1    -TP.MODEL
          LX5    -TP.MODEP
          BX1    -X1*X5      EXTRACT MODE OF EXPRESSION 
          LX5    TP.MODEP 
          SX1    X1-M.CHAR
          NZ     X1,A=UNT    IF EXPRESSION MUST BE A UNIT DESIGNATOR
          SHRINK T=IOARG
          SA5    PECB 
          BX6    X5 
          =X7    M.BOOL 
          CALL   NCS         ENTER DEFAULT UNIT DESIGNATOR IN CON TABLE 
          SA5    CONONE 
          BX4    X6 
          EMIT   IOUNT,*,T.IOARG
          ERRNZ  M.BOOL      MUST MERGE MODE INTO HEADER
          =A5    B6-1        RESTORE X5 
          =A4    A5-1        RESTORE X4 
          EQ     A=FMT       EXPRESSION MUST BE A FORMAT DESIGNATOR 
 C=ICC    SPACE  4,10 
**        C=ICC - CHECK I/O CONTROL CHARACTER VARIABLE
*         USED BY - ACCESS=       (FROM INQUIRE)
*                   BLANK=        (FROM INQUIRE)
*                   DIRECT= 
*                   FORM=         (FROM INQUIRE)
*                   FORMATTED=
*                   NAME= 
*                   SEQUENTIAL= 
*                   UNFORMATTED=
* 
*         EXIT   (X5) = KEYWORD PARAMETER (TP. FORMAT)
* 
*         CALLS  KWE, VAI 
  
  
 A=ICC    BSSENT 0
          SB4    B4-1 
  
 C=ICC    BSSENT 0
          RJ     KWE         SET UP FILL. FOR KEYWORD DIAGNOSTIC
          MX4    0           INDICATE DEFINITIONAL OCCURRANCE 
          SB3    E.IO18      ** SPECIFIER CANNOT BE CONST/EXPR
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          SB2    X0-M.CHAR
          ZR     B2,PAREXIT  IF CHARACTER 
          SA1    MOD.DPC+M.CHAR 
          LX6    X1 
          SA6    FILL.3 
          FATAL  E.IO05 
          EQ     PAREXIT
 C=ICCX   SPACE  4,10 
**        C=ICCX - CHECK I/O CONTROL CHARACTER EXPRESSION 
*         USED BY - ACCESS=  (FROM OPEN)
*                   BLANK=   (FROM OPEN)
*                   FILE= 
*                   FORM=    (FROM OPEN)
*                   STATUS= 
* 
*         EXIT   (X5) = KEYWORD PARAMETER (TP. FORMAT)
  
  
 A=ICCX   BSSENT 0
          SB4    B4-1 
  
 C=ICCX   BSSENT 0
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5      EXTRACT MODE 
          LX5    TP.MODEP 
          SB7    X0-M.CHAR
          ZR     B7,PAREXIT  IF TYPE CHARACTER
          RJ     KWE         SET UP FILL. FOR KEYWORD DIAGNOSTIC
          SA1    MOD.DPC+M.CHAR 
          BX6    X1 
          SA6    FILL.3 
          FATAL  E.IO05 
          EQ     PAREXIT
 C=ICI    SPACE  4,10 
**        C=ICI - CHECK I/O CONTROL INTEGER VARIABLE
*         USED BY - IOSTAT= 
*                   NEXTREC=
*                   NUMBER= 
*                   RECL=     (FROM INQUIRE)
* 
*         EXIT   (X5) = KEYWORD PARAMETER (TP. FORMAT)
* 
*         CALLS  KWE, VAI 
  
  
 A=ICI    BSSENT 0
          SB4    B4-1 
  
 C=ICI    BSSENT 0
          RJ     KWE         SET UP FILL. FOR KEYWORD DIAGNOSTIC
          MX4    0           INDICATE DEFINITIONAL OCCURRANCE 
          SB3    E.IO18      ** SPECIFIER CANNOT BE CONST/EXPR
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          SB2    X0-M.INT 
          ZR     X0,PAREXIT  IF BOOLEAN 
          ERRNZ  M.BOOL 
          ZR     B2,PAREXIT  IF INTEGER 
          SA1    MOD.DPC+M.INT
          LX6    X1 
          SA6    FILL.3 
          FATAL  E.IO05 
          EQ     PAREXIT
 C=ICIX   SPACE  4,10 
**        C=ICIX - I/O CONTROL POSITIVE INTEGER EXPRESSION
*         USED BY - BUFL= 
*                   REC=
*                   RECL=  (FROM OPEN)
* 
*         EXIT   (X5) = KEYWORD PARAMETER (TP. FORMAT)
* 
*         CALLS  KWE, LCH 
  
  
 A=ICIX   BSSENT 0
          SB4    B4-1 
  
 C=ICIX   BSSENT 0
          RJ     KWE         SET UP FILL. FOR KEYWORD DIAGNOSTIC
          LX1    X5 
          CALL   LCH         LOAD CONSTANT TEST 
          ZR     X0,ICIX1    IF BOOLEAN 
          ERRNZ  M.BOOL 
          SB7    X0-M.INT 
          NZ     B7,E.IO17   IF NOT INTEGER (OR BOOLEAN)
  
 ICIX1    ZR     B2,PAREXIT  IF NOT CONSTANT
          MI     X6,E.IO17   IF NEGATIVE, ERROR 
          NZ     X6,PAREXIT  IF NOT ZERO
          SA1    FILL.
          SA2    =4LBUFL
          IX2    X1-X2
          ZR     X2,PAREXIT  IF BUFL, BUFL=0 OKAY 
          EQ     E.IO17      REC=0 AND RECL=0 NOT OKAY
 C=ICL    SPACE  4,10 
**        C=ICL - CHECK I/O CONTROL LOGICAL VARIABLE
*         USED BY - EXIST=
*                   NAMED=
*                   OPENED= 
* 
*         EXIT   (X5) = KEYWORD PARAMETER (TP. FORMAT)
* 
*         CALLS  KWE, VAI 
  
  
 A=ICL    BSSENT 0
          SB4    B4-1 
  
 C=ICL    BSSENT 0
          RJ     KWE         SET UP FILL. FOR KEYWORD DIAGNOSTIC
          MX4    0           INDICATE DEFINITIONAL OCCURRANCE 
          SB3    E.IO18      ** SPECIFIER CANNOT BE CONST/EXPR
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          SB2    X0-M.LOG 
          ZR     B2,PAREXIT  IF LOGICAL 
          SA1    MOD.DPC+M.LOG
          LX6    X1 
          SA6    FILL.3 
          FATAL  E.IO05 
          EQ     PAREXIT
 C=IOL    EJECT 
**        C=IOL - MAKE I/O AP-LIST ENTRIES. 
* 
*         EXIT   TO IOL.RTN 
* 
*         CALLS  EMT, LCH, TPC, VAI 
  
  
 C=IOL    BSSENT 0           ENTRY... 
          RJ     PAX         PREPARE ARRAY CROSS-SECTION
          CALL   TPC         TEST FOR PASSED LENGTH CONCATENATION 
          BX1    X5 
          CALL   LCH         LOAD CONSTANT TEST 
          LX0    X5 
          BX4    X5 
          HX0    TP.EXPR
          SA5    CONONE 
          MI     X0,IOL30    IF ITEM IS EXPRESSION
          NZ     B2,IOL30    IF ITEM IS A CONSTANT
          LX0    TP.EXPRP-TP.INTRP
          PL     X0,IOL10    IF ITEM NOT INTERMEDIATE 
          LX0    TP.INTRP-TP.ARRP 
          PL     X0,IOL30    IF ITEM NOT SUBSCRIPTED ARRAY
          SA3    IODOIND
          ZR     X3,IOL30    IF I/O DO COLLAPSE NOT INVOLVED
          =A5    A3+1        FETCH PARTIAL COLLAPSE SIZE
          =X6    0
          SA6    A5 
          =A6    A5-1        CLEAR COLLAPSE INDICATORS
          EQ     IOL30
  
 IOL10    BX7    X4 
          HX7    TP.ORD 
          AX7    -TP.ORDL    ISOLATE ORDINAL
          SB2    X7 
          SB2    B2+B2
          SB2    B2+X7       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SB2    B2+WB.W
          SA1    T.SYM
          SA2    X1+B2       FETCH *WB* ENTRY 
          LX0    X4 
          SBIT   X2,WB.ARYP 
          PL     X2,IOL30    IF NOT ARRAY 
          SBIT   X0,TP.AREP 
          PL     X0,IOL30    IF SINGLE ELEMENT
          SBIT   X2,WB.PNTP/WB.ARYP+1 
          SA3    T.DIM
          MX0    -WB.PNTL 
          BX5    -X0*X2      ISOLATE T.DIM ORD
          SB3    X5 
          MX0    -DH.PSL
          SA1    X3+B3       FETCH DIMENSION PARAMETERS 
          LX1    -DH.PSP
          BX5    -X0*X1      ARRAY LENGTH 
          LX5    TP.BIASP 
          SBIT   X1,DH.ASP/DH.PSP-1 
          CLAS=  X2,TP,(SHRT),INT 
          BX5    X5+X2       MAKE INTO SHORT CONSTANT 
          PL     X1,IOL20    IF NOT ASSUMED SIZE ARRAY
          FATAL  E.IOL6 
          EQ     C=ERR
  
 IOL20    SBIT   X1,DH.VDP/DH.ASP 
          PL     X1,IOL30    IF NOT ADJUSTABLY DIMENSIONED
          SA1    S=VD 
          LX1    TP.ORDP
          CLAS=  X2,TP,(SHRT) 
          BX5    -X2*X5      REMOVE TP.SHRT (LEAVING BIAS + MODE) 
          BX5    X1+X5       ORD + BIAS + MODE = VD. PRODUCT OF SPANS 
  
*         (X4) = (1OP) = LIST ITEM (TP. FORMAT) 
*         (X5) = (2OP) = LENGTH INDICATOR (TP. FORMAT)
  
 IOL30    SA1    IODIR
          SA2    DATFLG 
          NZ     X1,IOL40    IF NOT INPUT DIRECTION 
          NZ     X2,IOL40    IF DATA LIST 
          RJ     AII         ADD INPUT ITEM TO T.ILI
  
 IOL40    SA1    IODTA
          MX0    -TP.MODEL
          LX4    -TP.MODEP
          BX0    -X0*X4      EXTRACT MODE 
          LX0    SP.MODEP 
          BX6    X1+X0       MERGE MODE INTO TURPLE HEADER
          SA6    IODTH
          LX4    TP.MODEP 
          EMIT   IODTH,*,T.IOARG
          EQ     IOL.RTN     EXIT...
 A=STR    SPACE  4,10 
**        A=STR - CHECK XXCODE *STRING* ADDRESS.
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         CALLS  OCT
  
  
 A=STR    BSSENT 0           ENTRY... 
          SA4    IODIR
          SB3    E.IOS7      ** STRING ADDRESS CANNOT BE CONST/EXPR 
          RJ     VAI         VALIDATE ADDRESSABLE ITEM
          SB2    X0-M.CHAR
          ZR     B2,E.IOS10  IF TYPE CHARACTER
          SX4    IC.STR 
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     PAREXIT
 C=UNT    SPACE  4,10 
**        C=UNT - UNIT DESIGNATOR CHECK 
* 
*         EXIT   (X5) = UNIT DESIGNATOR (TP. FORMAT)
  
  
 A=UNT    BSSENT
          SB4    B4-1 
 C=UNT    BSSENT
          EQ     PAREXIT
 CML      SPACE  4,10 
**        CML - CHECK FOR MATCH IN LIST (T.ILI) 
* 
*         I/O RESTART CALLS WILL BE ISSUED WHEN CERTAIN CONDITIONS ARE
*         SATISFIED FOR ITEMS IN INPUT LISTS. 
* 
*         ENTRY  (X6) = ITEM TO BE CHECKED (TP. FORMAT) 
*                (X0) = 0 IF ITEM IS AN INDEXED ARRAY 
*                     = .NZ. OTHERWISE. 
* 
*         KEEPS  X - 5,6  B - 2,4,5,6.
* 
*         CALLS  BBC,FII,CT1,IOJ. 
  
 CML30    SA5    CMLA 
          BX6    X5          RESTORE X6 
          =A5    A5+1        RESTORE X5 
          =A1    A5+1 
          SB6    X1          RESTORE B6 
          LX1    -18
          SB5    X1          RESTORE B5 
          LX1    -18
          SB2    X1          RESTORE B2 
  
 CML      SUBR   =           ENTRY/EXIT...
          SA1    T=ILI
          ZR     X1,EXIT.    IF TABLE EMPTY 
          SA6    CMLA        PRESERVE X6
          BX7    X5 
          =A7    A6+1        PRESERVE X5
          MX4    -18
          SX1    B6 
          BX7    -X4*X1 
          SX2    B5 
          BX2    -X4*X2 
          LX2    18 
          BX7    X7+X2
          SX2    B2 
          BX2    -X4*X2 
          LX2    18+18
          BX7    X7+X2
          =A7    A7+1        PRESERVE B2,B5,B6
          BX4    X0 
          MX1    -TP.ORDL 
          LX6    -TP.ORDP 
          BX0    -X1*X6      X0 = SYMORD
          CALL   CT1         GET EQV BIT INTO OPERAND 
          BX5    X6          X5 = OPERAND 
          CALL   BBC         CONVERT TO BASE/BIAS FORM
          BX0    X4 
          RJ     FII         FORMAT INPUT ITEM
          HX5    II.CHAR
          MI     X5,CML30    IF ITEM IS CHARACTER 
          MX0    -II.ORDL 
          MX7    -II.BIASL
          LX5    1+II.CHARP-II.ORDP 
          BX1    -X0*X5      X1 = ORDINAL OF ITEM 
          LX5    II.ORDP-II.BIASP 
          BX2    -X7*X5      X2 = BIAS OF ITEM
          LX5    II.BIASP 
          SA3    T=ILI
          SA4    T.ILI
          =B2    -1          B2 = LOOP COUNTER
          =B5    X3          B5 = LOOP LIMIT
          SB3    X4          B3 = FWA OF TABLE
  
 CML10    =B2    B2+1 
          GE     B2,B5,CML30 IF TABLE EXHAUSTED 
          SA3    B3+B2       X3 = TABLE ENTRY 
          LX3    -II.ORDP 
          BX4    -X0*X3      X4 = ORDINAL OF ENTRY
          IX4    X4-X1
          NZ     X4,CML10    IF ORDINALS DONT MATCH 
          LX3    II.ORDP
          BX4    X5+X3
          HX4    II.ARY 
          MI     X4,CML20    IF EITHER ONE IS AN INDEXED ARRAY
          LX3    -II.BIASP
          BX4    -X7*X3      X4 = BIAS OF ENTRY 
          IX4    X4-X2
          NZ     X4,CML10    IF BIASES ARE NOT EQUAL
  
**        HERE IF WE NEED TO ISSUE APLIST INTERRUPT.
  
 CML20    =X6    1
          RJ     IOJ         ISSUE APLIST INTERRUPT 
          EQ     CML30
  
 CMLA     BSS    1           TEMPORARY FOR X6 
          BSS    1                         X5 
          BSS    1                         B2,B5,B6 
 CMLB     BSS    1           TEMP FOR ARRAY NAME
 KWE      SPACE  4,10 
**        KWE -  KEYWORD PARAMETER DIAGNOSTIC SETUP 
* 
*         ENTRY  (ICKA) = I/O CONTROL KEYWORD (DPC) 
* 
*         EXIT   (FILL., FILL.2) = I/O CONTROL KEYWORD
  
  
 KWE      SUBR               ...ENTRY/EXIT... 
          SA1    ICKA        FETCH THE KEYWORD
          =A2    A1+1 
          BX6    X1 
          LX7    X2 
          SA6    FILL.
          =A7    A6+1 
          EQ     EXIT.
 OCT      SPACE  4,10 
**        OCT -  OUTPUT CONTROL TURPLE
* 
*         PUTS MODE OF CONTROL OPERAND INTO THE CONTROL TURPLE HEADER.
* 
*         ENTRY  (X4) = I/O CONTROL CODE
*                (X5) = I/O CONTROL OPERAND (TP. FORMAT)
* 
*         EXIT   CONTROL TURPLE OUTPUT
* 
*         USES   A1,A6  X0,X1,X6
* 
*         CALLS  EMT
  
  
 OCT      SUBR   0           ...ENTRY/EXIT... 
          SA1    IOCTL
          LX4    TP.IOCP
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5      EXTRACT MODE OF CONTROL OPERAND
          LX5    TP.MODEP 
          LX0    SP.MODEP 
          BX6    X1+X0
          SA6    OCTA 
          EMIT   OCTA,*,T.IOARG 
          EQ     EXIT.
  
 OCTA     BSS    1           I/O CONTROL TURPLE HEADER (WITH MODE)
 OST      SPACE  4,10 
**        OST -  OUTPUT SKIP TURPLE 
* 
*         OUTPUTS DEFAULT SKIP TURPLE, AS NECESSARY.
* 
*         USES   A1,A2,A6,A7  X0,X1,X2,X4,X5,X6,X7
* 
*         CALLS  OCT
  
  
 OST      SUBR               ...ENTRY/EXIT... 
          SA1    IODIR       I/O DIRECTION
          ZR     X1,OST1     IF INPUT 
          SA1    PKCA        FETCH DEFINED SPECIFIER MASK 
          SX2    1
          LX2    59-IC.IOS
          BX0    X1*X2
          ZR     X0,EXIT.    IF IOSTAT= NOT SPECIFIED 
          LX2    IC.IOS-IC.ERR
          BX0    X1*X2
          NZ     X0,EXIT.    IF ERR= SPECIFIED
  
*         EMIT DEFAULT SKIP LABEL.
  
 OST1     SX4    IC.SKP      1OP = CONTROL CODE 
          SA1    N.GL        NEXT GENERATED LABEL 
          BX6    X1 
          =X2    1
          =X7    X6+1 
          LX2    TP.GLP 
          SA7    A1          UPDATE GL COUNT
          LX1    TP.ORDP
          BX6    X1+X2       2OP = GL ORD 
          LX5    X6 
          SA6    IOSKP
          RJ     OCT         OUTPUT CONTROL TURPLE
          EQ     EXIT.
 VAI      SPACE  4,10 
**        VAI - VALIDATE ADDRESSABLE ITEM.
* 
*         VALIDATE THAT OPERAND IS LEGALLY ADDRESSABLE.  IF NOT, ISSUE
*         DIAGNOSTIC.  IF SO, AND THIS IS A DEFINING OCCURANCE, 
*         SET (WB.DEF), AND CHECK THAT AN ACTIVE DO-CONTROL INDEX IS
*         NOT BEING REDEFINED.
* 
*         ENTRY  (X5) = OPERAND.
*                (X4) .ZR. = THIS IS A DEFINING OCCURANCE.
*                     .NZ. = DO NOT SET/CHECK DEF.
*                (B3) = ADDRESS OF DIAGNOSTIC.
*                (LISTDIR) .NZ. = DEFINITION IS ONLY POTENTIAL. 
* 
*         EXIT   (X5) = OPERAND TO BE USED. 
*                            (TP.IOD) OR (TP.IOP) SET IF APPROPRIATE. 
*                (X0) = MODE OF OPERAND.
*                (B3) = ERROR INDICATION
* 
*         CALLS  DDR, DOA, PDM
* 
*         USES   A1-7.  B2,3,7.  X0-7.
  
  
 VAI      SUBR   =           ENTRY/EXIT...
          CALL   DOA         DETERMINE OPERAND ADDRESSABILITY 
          SB7    B3 
          NZ     X6,VAI8     IF INVALID STORE TARGET
          NZ     X4,EXIT.    IF NOT DEFINING OCCURANCE
          SA1    LISTDIR
          CLAS=  X6,WB,(DEF)
          BX7    X6+X2       MARK DEFINED IN SYMTAB 
          CLAS=  X3,TP,(IOD)
          BX5    X5+X3       INDICATE DEFINITION OF OPERAND 
          ZR     X1,VAI4     IF NOT LIST-DIRECTED OPERATION 
          LX3    -TP.IODP+TP.IOPP 
          BX5    X5+X3       ALSO MARK AS POTENTIAL DEFINITION
  
 VAI4     SA7    A2 
  
*         CHECK IF VARIABLE IS A DO CONTROL INDEX 
  
          =B3    0           INDICATE NOT DO CONTROL INDEX
          CALL   DDR         DIAGNOSE DO REDEFINITION 
          EQ     EXIT.
  
 VAI8     FATAL  B7 
          SB3    -1 
          EQ     EXIT.
          TITLE  I/O LIST PROCESSING. 
 AII      SPACE  4,10 
**        AII - ADD INPUT LIST ITEM TO TABLE. 
* 
*         ENTRY  (X4) = OPERAND OF LIST ITEM. 
*                (X5) = LENGTH OF LIST ITEM.
* 
*         CALLS  DOA,FII,BBC,ADDWD,CT1. 
* 
*         USES   ALL BUT X4,X5. 
  
 AII      SUBR               ENTRY/EXIT...
          BX6    X5 
          SA6    AIIA        PRESERVE X5
          BX6    X4 
          =A6    A6+1        PRESERVE X4
          BX5    X4 
          HX6    TP.INTR
          MI     X6,AII20    IF INTERMEDIATE OPERAND
          MX0    -TP.ORDL 
          LX6    1+TP.INTRP-TP.ORDP 
          BX0    -X0*X6      X0 = ORDINAL 
          CALL   CT1         COPY EQV BIT INTO OPERAND
          MX0    -TP.BIASL
          LX0    TP.BIASP 
          BX5    -X0*X5      ERASE ALL BUT BIAS 
          BX5    X5+X6       CREATE NEW OPERAND 
          SA1    CONONE 
          SA2    AIIA 
          =X0    1
          BX2    X1-X2
          ZR     X1,AII30    IF NOT INDEXED ARRAY 
          SX0    0
          EQ     AII30
  
 AII20    CALL   DOA
          NZ     X6,AII35    IF NOT ADDRESSABLE 
          =X0    A2-1 
          SA1    T.SYM
          IX0    X0-X1
          SX1    Z=SYM
          IX3    X0/X1       X3 = CORRECT ORDINAL 
          MX0    -TP.BIASL
          LX0    TP.BIASP 
          BX5    -X0*X5      ERASE ALL BUT BIAS 
          LX3    TP.ORDP
          CLAS=  X1,WB,(EQV)
          BX1    X1*X2       EXTRACT EQV BIT FROM *WB*
          LX1    -WB.EQVP+TP.EQVP 
          BX5    X5+X3
          BX5    X5+X1       CREATE OPERAND 
          =X0    0           INDICATE INDEXED ARRAY 
  
 AII30    CALL   BBC         CONVERT TO BASE/BIAS FORM
          RJ     FII         FORMAT INPUT LIST ITEM 
          BX6    X5          X6 = FORMATTED ITEM
          ADDWD  T.ILI
  
 AII35    SA5    AIIA+1      ARRAY OPERAND
          MX4    0           WE ARE DEFINING IT 
          SB3    E.IOL2      **CON/EXPR IN IO LIST
          RJ     VAI         VALIDATE ADDRESSABILITY
          BX4    X5          UPDATED OPERAND
          SA5    AIIA        RESTORE X5 
          EQ     EXIT.
  
 AIIA     EQU    SCR
 FII      SPACE  4,10 
**        FII - FORMAT INPUT LIST ITEM. 
* 
*         WILL PUT A TP. OPERAND INTO THE FORM NECESSARY
*         FOR ENTRY INTO T.ILI  . 
* 
*         ENTRY  (X5) = OPERAND 
*                (X0) = 0 IF II.ARY TO BE SET 
* 
*         EXIT   (X5) = FORMATTED OPERAND 
* 
*         USES   X - 1,2,5  A - 1,2  B - 2
  
 FII      SUBR               ENTRY/EXIT...
          SA2    T.SYM
          CLAS=  X1,TP,(ORD,BIAS) 
          BX5    X1*X5       ERASE ALL BUT ORD AND BIAS 
          ERRNZ  II.ORDP-TP.ORDP+II.ORDL-TP.ORDL
          ERRNZ  II.BIASP-TP.BIASP+II.BIASL-TP.BIASL
          MX1    -TP.ORDL 
          LX5    -TP.ORDP 
          BX1    -X1*X5      X1 = ORDINAL 
          LX5    TP.ORDP
          =B2    X1+WB.W
          LX1    1
          SB2    X1+B2       CONVERT TO *WB* INDEX
          SA1    X2+B2       *WB* 
          MX2    -WB.MODEL
          LX1    -WB.MODEP
          BX2    -X2*X1      X2 = MODE
          SX2    X2-M.CHAR
          MX1    0
          NZ     X2,FII10    IF NOT CHARACTER 
          LDBIT  X1,II.CHARP
  
 FII10    BX5    X5+X1
          NZ     X0,EXIT.    IF NOT INDEXED ARRAY 
          LDBIT  X1,II.ARYP 
          BX5    X5+X1
          EQ     EXIT.
 LST      SPACE  4,10 
**        LST -  PROCESS INPUT/OUTPUT LIST
* 
*         CALLED BY ALL I/O STATEMENT PROCESSORS WHICH HAVE AN I/O LIST.
* 
*         THE INITIALIZATION PROCESS, BEGUN IN IIC IS COMPLETED.  THEN
*         CVL IS CALLED TO COMPILE/COLLAPSE THE LIST.  IT CALLS C=IOL 
*         FOR EACH NON-COLLAPSIBLE LIST ITEM TO EMIT V=APIOD TURPLES. 
* 
*         ENTRY  (B4) _ SEPARATOR IN FRONT OF I/O LIST. 
*                (B6) = I/O METHOD INDICATOR (S.IOCALL ORDINAL) 
*                (T.ARG) - CONTAINS I/O CONTROL TURPLES (UNFINISHED)
* 
*         EXIT   TO FRONT END CONTROLLER (*FEC*)
* 
*         USES   ALL REGISTERS
* 
*         CALLS  ANSI, CVL, EMT, IOJ, OCT, OIL, PCT, TSX, WARN. 
  
  
 LST      BSSENT 0           ENTRY... 
 LST1     BSS    0
          SA2    B4 
          ZR     X2,LST3     IF NO I/O LIST 
          SB7    X2-O.COMMA 
          =A1    B4+1 
          =A2    A1+1 
          SA3    LISTDIR
          SX1    X1-O.COMMA 
          NZ     X1,LST3     IF NOT EXTRANEOUS COMMA
          ZR     X3,LST2     IF NOT LIST DIRECTED I/O 
          SA3    IODIR
          ZR     X3,LST2     IF INPUT 
          =B4    B4+1 
          ZR     B7,LST2     IF *,,*
          ZR     X2,LST3     IF COMMA TERMINATED LIST DIRECTED OUTPUT 
  
 LST2     FATAL  E.IO02 
          EQ     PSL
  
 LST3     RJ     OST         OUTPUT SKIP TURPLE 
  
 LST.S    BSS    0           **** ENTRY FOR ENCODE/DECODE ****
          SA1    IOARGT 
          =A2    A1-IOARGT+IOREF
          BX6    X1          SET DIRECTION INTO ARG MODE
          LX7    X2 
          SA6    ARGMODE
          SX6    B6 
          SA7    REFVAR 
          MI     B6,LST.N    IF NAMELIST OPERATION
          BX6    -X6         INDICATE NO I/O CALLS YET
          SA6    IONAM
          SB3    S.IOCALL 
          SB6    B6+B3       ADDRESS OF I/O NAME
          TAGSEX B6 
          SA1    T=BLST 
          LX6    X1 
          SA6    IODOLEN     PRESERVE FOR LATER RESTORATION 
  
*         STORE SPECIAL LEFT PAREN OVER LAST TOKEN OF UNIT/FORMAT 
*         DESIGNATOR (OR WHATEVER PRECEDES THE LIST), TO PROTECT
*         UNARY MINUS IN I/O LIST.  THEN COMPILE THE LIST, WITH 
*         PARSE MODE = 'EXPR'.
  
          SA1    ARGMODE
          SA2    IODTA
          SX7    O.SLP
          SX6    PM=EXPR
          SA7    B4-B1       INSTALL O.SLP BEFORE LIST
          RJ     CVL         COMPILE VARIABLE LIST
          SA1    B4-B1
          SA3    LISTDIR
          SX1    X1-O.COMMA 
          SA4    IODIR
          NZ     X1,LST10    IF *EOS* NOT PRECEDED BY *,* 
          ZR     X3,LST9     IF NOT LIST DIRECTED I/O 
          ZR     X4,LST9     IF INPUT DIRECTION 
          ANSI   E.IOL1      ** I/O LIST ENDING WITH *,* NON-ANSI 
          SA1    IODTA       FETCH TURPLE HEADER PROTOTYPE
          SX7    7           FUNNY MODE FOR LIBRARY 
          LX7    SP.MODEP 
          BX7    X1+X7
          SA7    IODTH
          SX4    7           FUNNY MODE FOR LIBRARY 
          LX4    TP.MODEP 
          SA1    CONZER 
          BX4    X4+X1       1OP = ZERO W/MODE=7
          SA5    CONONE      2OP = LENGTH = 1 
          EMIT   IODTH,*,T.IOARG
          EQ     LST10
  
 LST9     FATAL  E.IOL5      ** TRAILING COMMA NFG
  
 LST10    BSS 
          BX6    0
          RJ     IOJ         COMPILE TERMINAL CALL
          SA4    IOSKP
          ZR     X4,LST11    IF NO SKIP LABEL 
          =X5    0           2OP = NULL 
          EMIT   OPBSS,*
  
 LST11    BSS 
          CALL   OIL         OUTPUT IL
          EQ     PSL
 LST.N    SPACE  4,10 
**        LST.N - FINISH UP FOR *NAMELIST* I/O STATEMENT. 
* 
*         THE CONTROL TURPLES WILL BE FINISHED HERE (WHEN WE FETCH UP 
*         THE ACTUAL NAME).  TEST IS MADE FOR AN ERRONEOUS I/O LIST.
  
  
 LST.N    ANSI   E.ION1 
          SA1    IODIR
          SA5    B4 
          AX2    X1,B1       DIRECTION / 2
          SB6    S.NLST 
          SB6    B6+X2       ADJUST FOR I/O DIRECTION 
          TAGSEX B6 
          SB3    S.IOCALL 
          SX6    B3-B6       NEGATIVE INDICATES INITIAL CALL
          SA6    IONAM
          ZR     X5,LST10    IF *EOS* -- EXIT OK
          SB3    X5-O.) 
          NZ     B3,LST.N1   IF NOT *RP*
          SA5    B4+1 
          ZR     X5,LST10    IF *EOS* -- EXIT OK
 LST.N1   WARN   E.ION
          EQ     LST10
          TITLE  PARSE, COLLAPSE + TRANSLATE I/O/DATA VARIABLE LIST.
 CVL      SPACE  4,10 
**        CVL -  COMPILE INPUT/OUTPUT/DATA LIST.
* 
*         IF THE LIST IS NOT EMPTY, IOD IS CALLED TO SCEARCH THE LIST 
*         FOR IMPLIED DO LOOPS. 
* 
*         TESTING FOR IMPLIED DO LOOP COLLAPSE IS PERFORMED AND 
*         COLLAPSE IS PERFORMED WHERE POSSIBLE.  EACH LIST ITEM IS THEN 
*         PARSED.  THE APPROPRIATE COMMA PROCESSOR EMITS TURPLES. 
* 
*         ENTRY  (B4) -> SEPARATOR IN FRONT OF LIST.
*                (X1) = ARGMODE (AM.).
*                (X2) = TURPLE HEADER (TH.).
*                (X6) = PARSE-MODE FOR LIST ITEMS (PM=).
*                THE LIST TERMINATES WITH TWO (O.EOS) TOKENS. 
* 
*         EXIT   (B4) -> TERMINATING (O.EOS) TOKEN. 
* 
*         USES   ALL REGISTERS
* 
*         CALLS  EMT, FATAL, IOJ, OIL, PAR. 
  
  
 CVL      SUBR   =           ENTRY/EXIT...
          BX7    X1 
          HX7    AM.REF 
          AX7    -AM.REFL    EXTRACT CROSS REFERENCE CHARACTER
          SA7    IOREF
          SA4    T=BLST 
          BX7    X2          SAVE CALLER'S TURPLE HEADER
          SA3    B4 
          SA7    CVLTH
          BX7    X4          REMEMBER ORIGINAL DEPTH OF BLOCK-STRUCTURES
          =A2    B4+1 
          SA6    CVLPM       SAVE CALLER'S PARSE MODE 
          SA7    IODOLEN
          ZR     X3,EXIT.    IF EMPTY LIST
          ZR     X2,CVL10    IF PRINT *,
          BX7    X1 
          SX6    B4 
          SA7    CVLAM
          SA7    ARGMODE
          SA6    IODOCOL     INITIALIZE POINTER 
          RJ     IOD         MARK DO LOOPS
          SA4    DATFLG 
          NZ     X4,CVL1     IF *DATA*
          SHRINK T=IOLC 
          SA6    TL=LCI 
  
 CVL1     SX6    O.COMMA
          SA6    B4          SET OFF I/O LIST 
  
  
*         CVL.N  - PROCESS NEXT ELEMENT OF THE I/O LIST.
* 
*         ENTRY  (B4) -> CURRENT TOKEN, MINUS ONE.
* 
*         FIRST, EXAMINE ELEMENT AND DETERMINE WHAT TO DO --
*                <EOS>  _ END-OF-STRING.  CONCLUDE LIST AT "CVL8".
*                O.DOBI _ DO-BEGIN.  GO TO "DOB" TO COMPILE DO INITIAL
*                         TURPLES.  RETURN TO HERE FOR NEXT ELEMENT.
*                O.DOCI _ DO-CLOSE.  GO TO "DOC" TO COMPILE IMPLIED-DO
*                         CONCLUSION TURPLE.  RETURN TO HERE FOR ELEMENT
*                         PAST THE DO.
*                O.DCBI _ DO-COLLAPSE BEGIN.  GO TO "DCB" TO PROCESS
*                         MULTIPLY TURPLE IF NEEDED.  SET UP COLLAPSE 
*                         PROTOTYPE AND RETURN HERE TO PROCESS ARRAY. 
*                O.DCCI _ DO-COLLAPSE CONCLUSION.  MAKE AN INCREMENT
*                         TURPLE AND RETURN TO PROCESS NEXT ELEMENT.
*                <ELSE> _ A SIMPLE (OR ERRONEOUS) LIST IS AT HAND.
*                         PARSE IT. 
  
  
 CVL.N    =A2    B4+1        FETCH ELEMENT
          SA1    T=PAR
          BX6    X1 
          SB4    B4+1 
          SA6    CURST       RESET TO INHIBIT SQUEEZE 
          SB7    X2-O.DOBI
          ZR     X2,CVL8     IF END OF LIST 
          MI     B7,CVL4     IF SIMPLE LIST 
          JP     B7+*+1 
  
          LOC    O.DOBI 
 O.DOBI   EQ     DOB         DO BEGIN 
 O.DOCI   EQ     DOC         DO CONCLUSION
 O.DCBI   EQ     DCB         DO COLLAPSE BEGIN
 O.DCCI   EQ     DCC         DO COLLAPSE CONCLUSION 
          IFEQ   TEST,ON,1
          EQ     "BLOWUP"    ERROR
          LOC    *O 
  
**
*         HANDLE SIMPLE, BREAK-FREE LIST. 
*         *PAR* DOES THE DIRTY WORK, CALLING ON THE COMMA CHECKER 
*         C=DVL OR C=IOL.  HE WILL RETURN TO US UPON FINDING
*         AN *EOS*, WHICH MAY HAVE BEEN INVENTED BY SOME IMPLIED
*         LIST PROCESSING.  RETURN TO *CVL.N* TO CHECK. 
  
 CVL4     SA1    CVLPM
          BX6    X1 
          SA6    PARMODE
          CALL   PAR         PARSE SIMPLE LIST
          =B4    B4+1 
          EQ     CVL.N       LOOP.. 
  
  
*         HERE TO WRAP-UP WHEN END OF LIST IS REALLY ENCOUNTERED -- 
*         TEST FOR UNTERMINATED IMPLIED DO LOOPS, AND THEN INSURE 
*         THAT (T.BLST) IS THE SAME AS IT WAS UPON ENTRY. 
  
 CVL8     BSS 
          SA3    IODOLEN
          SA2    T=BLST 
          =B4    B4-1        B4 _ O.EOS TOKEN 
          BX0    X2-X3       CHECK FOR UNPROCESSED DO-S 
          LX6    X3 
          ZR     X0,EXIT.    IF ALL DO-S BALANCED 
          SHRINK T=BLST,X6   RESET STRUCTURES TABLE 
          FATAL  E.IO14      ** UN-TERMINATED IMPLIED LOOPS 
          EQ     EXIT.
  
 CVL10    SB4    B4+1 
          EQ     EXIT.
  
 CVLAM    BSS    1           SAVE CALLER'S ARGUMENT MODE
 CVLPM    BSS    1           SAVE CALLER'S PARSE MODE 
 CVLTH    BSS    1           SAVE CALLER'S DATA TURPLE-HEADER 
 DCB      SPACE  4,10 
**        DCB  - I/O DO COLLAPSE BEGIN
* 
*         ENTRY  (B4) _ DO-COLLAPSE BEGIN TOKEN (O.DCBI)
*                (T.TB) = REFORMATTED BY *IOD* AND *IDC*
* 
*         EXIT   (B4) _ OBJECT ARRAY OF COLLAPSE
* 
*         USES   A1,A2,A3,A4,A5,A6,A7  X1,X2,X3,X4,X5,X6,X7  B4,B5
* 
*         CALLS  CT1, EMT, NCS
  
  
 DCB      BSS    0           ...ENTRY 
          SA1    B4 
          AX1    TB.IBCCP 
          =B4    B4-1        RESET FOR *DCB3* LOOP
          =B5    X1+DC=CCT   POINTER TO DO COLLAPSE CONCLUSION TOKEN
          ERRNZ  18-TB.IBCCL
          =A4    B5+DC=VAR   FETCH VARIABLE COLLAPSE MULTIPLIER 
          ZR     X4,DCB2     IF COLLAPSE NOT VARIABLE 
  
*         THE LAST LIMIT WAS VARIABLE, MUST OUTPUT MULTIPLY TURPLE
  
          LX0    X4 
          CALL   CT1         GET TP. FORMAT 
          BX4    X6          FOR MULTIPLY TURPLE, IF NECESSARY
          =A5    B5+DC=ISV   GET INITIAL VALUE
          LX0    X5 
          SBIT   X0,TP.SHRTP
          PL     X0,DCB03    IF NOT SHORT CONSTANT
          HX5    TP.BIAS
          AX5    -TP.BIASL   ISOLATE CONSTANT 
          SX6    X5-1        BIAS BY -1 
          ZR     X6,DCB09    IF INITIAL=1 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT
          BX5    X6 
          EMIT   V=SUB.I,BOTH   SUBTRACT INITIAL FROM LIMIT 
          EQ     DCB06
  
 DCB03    EMIT   V=SUB.I,BOTH   SUBTRACT INITIAL FROM LIMIT 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX4    X6+X2       FORM INDIRECT OPERAND
          SA5    CONONE      GET CONSTANT ONE 
          EMIT   V=ADD.I,BOTH    ADD ONE
  
 DCB06    SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX6    X6+X2       FORM INDIRECT OPERAND
          BX4    X6 
  
 DCB09    =A5    B5+DC=SIZ   FETCH COLLAPSE SIZE
          BX6    X4 
          =X2    X5-1 
          NZ     X2,DCB1     IF SIZE .NE. 1 
          SA6    IODOIND+1   THE VARIABLE MULTIPLIER WILL BE SIZE 
          EQ     DCB3 
  
 DCB1     SA1    WO.DOOT     GET TRIP COUNT 
          ZR     X1,DCB15    IF ZERO TRIP DO
          SA5    CONONE      GET CONSTANT ONE 
          EMIT   V=MAX0,BOTH   GUARANTEE ONE TRIP 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX4    X2+X6       FORM INDIRECT OPERAND
          =A5    B5+DC=SIZ   FETCH COLLAPSE SIZE
  
 DCB15    BX6    X5 
          =X7    M.INT
          CALL   NCS
          LX5    X6 
          EMIT   V=MUL.I,BOTH 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX6    X6+X2       MAKE INTERMEDIATE OPERAND
          SA6    IODOIND+1   SAVE AS SIZE OPERAND 
          EQ     DCB3 
  
 DCB2     =A5    B5+DC=SIZ   FETCH COLLAPSE SIZE
          LX5    TP.BIASP 
          CLAS=  X2,TP,(SHRT) 
          BX7    X2+X5
          SA7    IODOIND+1   SAVE COLLAPSE SIZE 
  
*         OUTPUT INITIAL SUBSCRIPT VALUE TURPLES
  
 DCB3     SA1    B4+1 
          SB2    X1-O.DCBI
          ERRNZ  18-TB.TOTL 
          NZ     B2,CVL.N 
          =B4    B4+1 
          HX1    TB.IBCC
          AX1    -TB.IBCCL   ISOLATE COLLAPSE TOKEN ADDRESS 
          SA1    X1          FETCH COLLAPSE TOKEN 
          =A4    A1+DC=ISV
          HX1    TB.ICIX
          AX1    -TB.ICIXL   EXTRACT INDEX TO CONTROL INDEX 
          SA5    X1+IDCIDX
          EMIT   V=STR.I,BOTH 
          EQ     DCB3 
 DCC      SPACE  4,10 
**        DCC -  I/O DO COLLAPSE CONCLUSION 
* 
*         ENTRY  (B4) _ DO-COLLAPSE CONCLUSION TOKEN (O.DCCI) 
*                (T.TB) = REFORMATTED BY *IOD* AND *IDC*
* 
*         EXIT   (B4) _ CLOSING *)*+1 OF COLLAPSED DO LEVEL 
* 
*         USES   A1  X1  B4 
* 
*         CALLS  EMT
  
  
 DCC      BSS    0           ...ENTRY 
          SA1    B4 
          AX1    TB.ICCPP    ISOLATE POINTER TO CLOSING *)* 
          =B4    X1+1        POINT PAST CLOSING *)* 
          ERRNZ  18-TB.ICCPL
          EQ     CVL.N
 DOB      SPACE  4,10 
**        DOB -  I/O LIST DO-BEGIN PROCESSING.
* 
*         ENTRY  (B4) _ O.DOBI MARK 
* 
*         EXIT   TO *CVL.N*.
*                (B4) PRESERVED.
* 
*         USES   ALL BUT A0.
* 
*         CALLS  CDI, IOJ, MXP
  
  
 DOB      BSS    0           ENTRY
          RJ     IDC         PROCESS I/O IMPLIED DO COLLAPSE
          ZR     B7,DOB1     IF LOOP NOT COMPLETLY COLLAPSED
          PL     B7,DOB8     IF COMPLETE COLLAPSE 
          SX6    1
          RJ     IOJ         INTERRUPT LIST 
          EQ     DOB8 
  
 DOB1     SX6    1
          RJ     IOJ         INTERRUPT LIST 
          SA2    B4 
          SA1    N.GL 
          AX2    TB.IOIXP    ISOLATE LINK TO DO-INDEX 
          SX2    X2          ADDRESS OF INDEX 
          =X7    O.=
          =X6    X1+1        UPDATE PROGRAM TAG 
          SX0    B4 
          =A7    X2+1 
          SA6    A1 
          LX0    -18
          BX3    X6+X0
          =B4    X2+1        POINT TO*=*
          LX3    2*18 
          IX7    X3+X2       = 24/TP.ORDL, 18/FWA-DO, 18/INDEX-ADDR 
          SA7    DOBA        SAVE O.DOCI POINTERS 
  
**        PARSE *DO* INITIAL CODE.
*         (X6) = L-TAG FOR LOOP.
  
          CALL   CDI         PARSE IT 
  
          =X0    O.DOCI 
          SA3    DOBA 
          BX4    X6+X0       SAVE *DO-ERROR* FLAG 
          SB3    B4          _ )
          SB2    X3          ADDRESS OF DO-INDEX
          AX3    18 
          SB4    X3          RESTORE (B4) _ FRONT OF DO-LIST
          SX2    B4-B3
          BX6    O.EOS
          =A6    B2-1        FORCE *EOS* AT END OF LIST 
          IX0    X3-X2
          LX0    18 
          IX7    X0+X4
          SA7    B2          STORE DO-CLOSE MARK (OVER THE INDEX) 
,                            24/ TP.ORDL,  18/ _),  18/ O.DOCI
  
**        PARSER ARGUMENT MODE MAY HAVE BEEN DISTURBED BY ONE OF THE
*         I/O DO LOOP PROCESSORS (IDC, CDI).
*         RESET IT AS EXPECTED BY *CVL.N*.
  
 DOB8     SA1    CVLAM
          BX6    X1          RESET PARSER ARGUMENT MODE 
          SA6    ARGMODE
          EQ     CVL.N       EXIT.. 
  
 DOBA     BSS    1           TEMP 
 DOC      SPACE  4,10 
**        DOC -  I/O LIST DO-CONCLUSION PROCESSING. 
* 
*                MAKES DO-TERMINATION ENTRY IN PARSED FILE. 
* 
*         ENTRY  (B4) _ O.DOCI MARK.
* 
*         EXIT   TO *CVL.N*.
*                (B4) _ NEXT ITEM PAST THE DO.
* 
*         USES   ALL. 
* 
*         CALLS  IOJ, MXP, PDT
  
  
 DOC      BSS    0           ENTRY
          SX6    1
          RJ     IOJ         INTERRUPT LIST 
          SA3    B4          24/ TP.ORDL,  18/ _NEXT,  18/ O.DOCI 
          AX3    18 
          =B4    X3+1        SKIP THE COMMA 
 DOC2     SA2    B4 
          SB2    X2-O.) 
          NZ     B2,DOC4     IF NO REDUNDANT PAREN
          =B4    B4+1        SKIP REDUNDANT PAREN 
          EQ     DOC2 
  
 DOC4     AX3    18 
          SX2    X3          ISOLATE TP.ORDL OF THIS DO 
          MI     X3,DOC6     IF ERROR IN DO-DEFINITION
          CALL   PDT         PROCESS DO TERMINATION (PASS 1)
  
 DOC6     SA1    B4+B1
          =A1    B4+1 
          NZ     X1,CVL.N    IF NOT EOS 
          =A2    B4 
          SX2    X2-O.COMMA 
          NZ     X2,CVL.N    IF EOS, CHECK PRECEEDING ELEMENT 
          =B4    B4+1 
          EQ     CVL.N       EXIT.. 
 IDC      EJECT 
**        IDC -  IMPLIED DO COLLAPSE
* 
*         THIS ROUTINE ATTEMPTS TO COLLAPSE AN I/O IMPLIED DO STRUCTURE.
*         IF SUCCESSFUL, ONE OR MORE LEVELS OF THE DO NEST WILL BE
*         DISCARDED, AND AN I/O AP-LIST DATA TURPLE WILL BE OUTPUT, 
*         WITH THE SIZE OPERAND THE AMOUNT OF COLLAPSE. 
* 
*         ENTRY  (B4) _ I/O DO-BEGIN TOKEN
*                (T.TB) = I/O LIST, WITH IMPLIED DOS MARKED BY *IOD*
*                (IODOCOL) = POINTER TO LAST DO NEST PROCESSED
* 
*         EXIT   (B7) = 0  -  NO (OR PARTIAL) COLLAPSE
*                (B4) _ I/O DO-BEGIN TOKEN
* 
*                (B7) = 1  -  COMPLETE COLLAPSE 
*                (B4) _ CLOSING RIGHT PAREN + 1 
* 
*                (B7) = -1 - COMPLETE COLLAPSE (DIMENSION .LT. COLLAPSE)
*                (B4) _ FIRST I/O DO-COLLAPSE BEGIN TOKEN 
* 
*                (T.TB) = MODIFIED WITH DO-COLLAPSE TOKENS, AS NECESSARY
*                (IODOCOL) = UPDATED AS NECESSARY 
* 
*         USES   ALL
* 
*         CALLS  AII, BBC, CML, CT1, EMT, NCS, PCI, SSY 
  
  
 IDC      SUBR               ...ENTRY/EXIT... 
          SA1    DATFLG 
          SX1    X1-PM=DATA 
          ZR     X1,IDC5     IF *DATA* CALLING
          SA1    CO.DBSB
          MI     X1,EXIT.    IF ARRAY BOUNDS CHECKING ON
  
 IDC5     =B7    0
          SA1    IODOCOL
          SA2    B4          FETCH THE I/O DO-BEGIN TOKEN 
          HX2    TB.IOCP
          AX2    -TB.IOCPL   ISOLATE CLOSING RIGHT PAREN POINTER
          IX1    X2-X1
          MI     X1,EXIT.    IF THIS DO STRUCTURE ALREADY PROCESSED 
          BX6    X2 
          SA6    A1          RESET IODOCOL FOR THIS DO NEST 
  
*         TEST NESTING LEVEL
  
          SA4    B4          INITIALIZE FETCH 
          =B6    1           COUNT OF NESTING LEVEL 
          =B5    MAX.DIM     LIMIT
  
 IDC10    =A4    A4+1        FETCH NEXT TOKEN 
          SB3    X4-O.DOBI
          ERRNZ  18-TB.TOTL-TB.TOTP 
          NZ     B3,IDC15    IF NOT DO BEGIN TOKEN
          =B6    B6+1        INCREMENT NESTING LEVEL
          GT     B6,B5,EXIT. IF TOO MANY LEVELS OF NESTING
          EQ     IDC10       CONTINUE 
  
*         TEST FOR SUBSCRIPTED ARRAY
*                (A4) _ FIRST NON DO-BEGIN TOKEN
*                (B6) = DO NESTING LEVEL
*                (X4) = THE TOKEN 
  
 IDC15    =B3    B3+O.DOBI-O.VAR
          NZ     B3,EXIT.    IF NOT VARIABLE
          MX0    TB.TOCL
          BX6    X0*X4       ISOLATE ARRAY NAME 
          CALL   SSY
          PL     B7,IDC20    IF IN SYMBOL TABLE 
          =B7    0
          EQ     EXIT.       CANT BE ARRAY
  
 IDC20    SBIT   X2,WB.ARYP 
          =B7    0
          PL     X2,EXIT.    IF NOT ARRAY 
          CALL   CT1         MAKE TAG 
          SA6    IDCA        SAVE 
          LX5    X6 
          BX4    X2          PRESERVE ACCROSS BBC 
          CALL   BBC         BASE/BIAS CONVERT ARRAY
          LX2    X4          RESTORE
          BX6    X5 
          SA6    IDCM        SAVE 
          SX6    B6 
          =B7    0
          HX2    WB.PNT 
          MX0    -WB.PNTL 
          LX2    WB.PNTL
          BX2    -X0*X2      ISOLATE T.DIM POINTER
          SA1    T.DIM
          SB2    X2 
          SA2    B2+X1       FETCH DIMENSION HEADER 
          HX2    DH.DIM 
          AX2    -DH.DIML    ISOLATE NUMBER OF DIMENSIONS 
          IX3    X2-X6
          MI     X3,EXIT.    IF NESTING LEVEL EXCEEDS DIMENSIONALITY
          =X7    B2+1        POINT PAST THE HEADER ENTRY
          SA7    IDCB        SAVE POINTER TO FIRST DIMENSION
          =A4    A4+1        ADVANCE PAST ARRAY NAME
          SB2    X4-O.( 
          NZ     B2,EXIT.    IF NOT SUBSCRIPTED ARRAY 
          SA6    IDCC        SAVE NESTING LEVEL 
          SX7    B4 
          BX6    X2 
          SA7    IDCD        SAVE POINTER TO INITIAL DO-BEGIN 
          SA6    IDCG        SAVE DIMENSIONALITY
          SA1    T=PAR
          SA2    T=REF
          LX6    X1 
          BX7    X2 
          SA6    IDCJ        SAVE LENGTH OF PARSE FILE FOR RESET
          SA7    IDCN        SAVE EXTENT OF XREF FOR RESTORE
          SA1    LOSTREF
          BX6    X1 
          SA6    IDCO        SAVE REFERENCE COUNT FOR RESTORE 
  
**        PROCESS THE SUBSCRIPTS
* 
*         SUBSCRIPTS WILL BE TRANSLATED BY *PAR*.  INDIVIDUAL SUBSCRIPTS
*         ARE PROCESSED BY A=DOCS/C=DOCS. 
  
 IDCEXC   BFMIC  TP,(BIAS,ARR,ADDR,1ATR,INTR,SHRT,GL) 
  
          SB4    A4 
          MX6    0           INITIALIZE SUBSCRIPT COUNT 
          SA1    DOCOLS 
          SA6    IDCE 
          RJ     PCI         PARSE COLLAPSE SUBSCRIPTS
          SA1    IDCJ        T.PAR UPON ENTRY 
          SA2    IDCE        NUMBER OF SUBSCRIPTS 
          SHRINK T=PAR,X1 
          =B4    B4+1        ADVANCE POINTER
          SA3    IDCG        ARRAY DIMENSIONALITY 
          IX2    X2-X3
          NZ     X2,IDCEX    IF SUBSCRIPT/DIMENSIONALITY MISMATCH 
  
*         PROCESS INDUCTION VARIABLES 
*                (B4) _ *,* FOLLOWING SUBSCRIPTS
  
          =X6    0
          SA6    IDCH        SAVE INDEX 
          =B3    0           INITIALIZE INDEX INTO IDCIDX 
          =X7    1
          SA7    IDCI        INITIALIZE COLLAPSE MULTIPLIER 
  
*         PROCESS INDEX 
  
 IDC30    SA4    B3+IDCIDX
          MI     X4,IDCEX    IF COLLAPSE INVALID FOR THIS LEVEL 
          SA1    B4 
          SB2    X1-O.COMMA 
          NZ     B2,IDCEX    IF NOT INDEX SEPERATOR 
          =A1    B4+1 
          =B4    B4+1 
          SB2    X1-O.VAR 
          NZ     B2,IDCEX    IF NOT AN INDEX
          MX6    TB.TOCL
          BX6    X6*X1       NAME ONLY
          SA6    FILL.
          CALL   SSY
          MI     B7,IDCEX    IF NOT IN SYMBOL TABLE, NOT A CORRECT INDEX
          CALL   CT1         MAKE TP. FORMAT
          BX5    X6 
          CALL   BBC         CONVERT TO BASE/BIAS FORM
          BX6    X5 
          SA6    IDCCV       SAVE CONTROL VARIABLE
          IX0    X4-X5
          NZ     X0,IDCEX    IF IMPLIED INDEX NOT SAME AS SUBSCRIPT 
  
*         CHECK FOR POSSIBLE REDEFINITION OF IMPLIED DO INDICIES
*         PREVIOUSLY COLLAPSED. 
  
          ZR     B3,IDC32    IF FIRST LEVEL 
          SB2    B3-1 
          SA1    IDCIDX 
  
 IDC31    SA2    A1+B2
          IX2    X5-X2
          ZR     X2,IDCEX    IF A DO INDEX REDEFINITION 
          SB2    B2-1 
          PL     B2,IDC31    IF MORE TO CHECK 
  
 IDC32    SA1    IODIR
          SX1    X1-S=OUT 
          NZ     X1,IDC33    IF NOT OUTPUT DIRECTION
          SA5    IDCA        X5 = OPERAND OF ARRAY
          CALL   BBC         CONVERT TO BASE/BIAS FORM
          LX5    -TP.ORDP 
          MX2    -TP.ORDL 
          LX4    -TP.ORDP 
          BX5    -X2*X5      X5 = SYMORD OF ARRAY 
          BX4    -X2*X4      X4 = SYMORD OF INDEX 
          IX3    X4-X5
          ZR     X3,IDCEX    IF INDEX IS EQUIVALENCED TO THE ARRAY
  
 IDC33    =A4    B4+1 
          =B4    B4+1 
          SB2    X4-O.= 
          NZ     B2,IDCEX    IF NOT *=* 
          SA1    CONONE 
          BX6    X1          INITIALIZE INCREMENT = 1 
          MX7    0           INITIALIZE INDUCTION VARIABLE COUNT
          SA6    IDCINC 
          SA7    IDCF 
          SA1    DOCOLI 
          RJ     PCI         PARSE COLLAPSE INDICIES
          SA1    IDCJ        T.PAR UPON ENTRY 
          SHRINK T=PAR,X1 
          =B4    B4+1        ADVANCE POINTER
  
*         CHECK INCREMENT 
  
          SA1    IDCINC      FETCH INCREMENT
          SA2    CONONE 
          IX2    X1-X2
          NZ     X2,IDCEX    IF NON-UNIT INCREMENT, DO MUST MATERIALIZE 
  
*         CHECK INITIAL 
  
          SA2    IDCB        T.DIM POINTER
          SA1    T.DIM
          =B2    X2+D2.W
          SA3    X1+B2       FETCH *D2* ENTRY 
          BX4    X3 
          HX3    D2.LB
          AX3    -D2.LBL     EXTRACT LOWER BOUND
          SA1    IDCINT      FETCH INITIAL VARIABLE 
          LX2    X1 
          SBIT   X1,TP.SHRTP
          MI     X3,IDCEX    IF ADJUSTABLE LOWER BOUND
          MI     X1,IDC35    IF SHORT CONSTANT
          SA1    IDCE        SUBSCRIPT COUNT
          SA5    IDCH        INDEX OF PROCESSING LEVEL
          =X5    X5+1 
          IX1    X1-X5
          ZR     X1,IDC36    IF LAST SUBSCRIPT
          EQ     IDCEX
  
 IDC35    HX2    TP.BIAS
          AX2    -TP.BIASL   EXTRACT INITIAL VALUE
          SB3    59-23
          LX3    B3,X3
          AX3    B3          SIGN EXTEND LOWER BOUND
          IX0    X2-X3
          MI     X0,IDCEX    IF INITIAL .LT. LOWER BOUND
          =A1    A3+D1.W-D2.W 
          HX1    D1.SPAN
          MI     X1,IDC36    IF UPPER OR LOWER VARIABLE 
          ZR     X0,IDC37    IF INITIAL = LOWER 
  
 IDC36    SA1    IDCH 
          SA1    X1+IDCIDX
          MX6    -0 
          =A6    A1+1        LAST LEVEL OF COLLAPSE 
  
*         CHECK LIMIT 
*                (X2) = INITIAL VALUE 
  
 IDC37    LX4    -D2.UBP-DM.INFL
          AX4    -DM.INFL    EXTRACT (SIGN EXTEND) UPPER BOUND
          SA1    IDCLMT      FETCH LIMIT VARIABLE 
          LX0    X1 
          SBIT   X1,TP.SHRTP
          PL     X1,IDC38    IF NOT SHORT CONSTANT
          HX0    TP.BIAS
          AX0    -TP.BIASL   EXTRACT LIMIT VALUE
          IX2    X0-X2
          IX0    X0-X4
          SA4    IDCINT      GET INITIAL VALUE
          SBIT   X4,TP.SHRTP
          BX2    X2*X4       SET X2.GE.0 IF NOT SHORT CONS. 
          MI     X2,IDCEX    IF INITIAL .GT. LIMIT
          ZR     X0,IDC40    IF LIMIT .EQ. UPPER BOUND
          EQ     IDC39
  
 IDC38    BX0    X1          SAVE SHIFTED LIMIT OPERAND 
          SA5    IODIR
          SB2    X5-S=INP 
          NZ     B2,IDC39    IF NOT INPUT 
          LX1    1+TP.SHRTP 
          BX5    X1 
          RJ     BBC
          BX4    X5          SAVE BASE/BIAS FORM OF LIMIT 
          SA5    IDCA 
          RJ     BBC         GET BASE/BIAS FORM OF ARRAY
          BX4    X4-X5
          MX6    -TP.ORDL 
          LX4    -TP.ORDP 
          BX6    -X6*X4 
          ZR     X6,IDCEX    IF LIMIT EQUIVALENCED TO ARRAY 
          BX1    X0 
  
 IDC39    SA2    IDCH 
          SA2    X2+IDCIDX
          MX6    -0 
          =A6    A2+1        LAST LEVEL OF COLLAPSE 
          =X6    0
          SA6    IDCP        CLEAR LENGTH BIAS
          MI     X1,IDC40    IF SHORT CONSTANT
          SA2    IDCINT      FETCH INITIAL
          HX2    TP.BIAS
          AX2    -TP.BIASL   EXTRACT INITIAL VALUE
          =X0    1
          IX6    X2-X0       CALCULATE LENGTH BIAS
          SA6    IDCP        SAVE LENGTH BIAS 
          LX1    TP.SHRTP+TP.SHRTL  RESTORE 
          SA2    ="IDCEXC"   EXCLUSION MASK 
          MX0    -TP.MODEL
          BX1    X0*X1       REMOVE MODE
          ERRNZ  TP.MODEP 
          BX2    X1*X2
          NZ     X2,IDCEX    IF NOT SIMPLE VARIABLE 
  
*         PERFORM COLLAPSE OPERATIONS 
*         TOKENS IN T.TB, STARTING WITH THE INDEX WILL BE REPLACED BY:  
*         1. DO COLLAPSE CONCLUSION TOKEN 
*         2. INITIAL SUBSCRIPT VALUE
*         3. COLLAPSE SIZE
*         4. VARIABLE COLLAPSE MULTIPLIER (IF NEEDED) 
*         5. BIAS (OFFSET OF LAST COLLAPSE, IF NEEDED)
* 
*                (X3) = LOWER BOUND 
*                (X4) = UPPER BOUND 
  
 IDC40    SA1    IDCINT      GET INITIAL VALUE
          BX5    X1 
          SBIT   X1,TP.SHRTP
          MI     X1,IDC42    IF SHORT CONSTANT
          BX0    X1 
          SA1    IODIR       GET IO DIRECTION 
          SB2    X1-S=INP 
          NZ     B2,IDC41    IF NOT INPUT 
          RJ     BBC         CONVERT INITIAL TO BASE/BIAS 
          BX4    X5 
          SA5    IDCA        GET ARRAY
          RJ     BBC         CONVERT ARRAY TO BASE/BIAS 
          BX4    X4-X5
          MX6    -TP.ORDL 
          LX4    -TP.ORDP 
          BX6    -X6*X4 
          ZR     X6,IDCEX    IF INITIAL EQUIV. TO ARRAY 
  
 IDC41    BX1    X0          RETRIEVE INITIAL 
          LX1    TP.SHRTP+TP.SHRTL
          SA2    ="IDCEXC"
          MX0    -TP.MODEL
          BX1    X0*X1
          ERRNZ  TP.MODEP 
          BX2    X1*X2
          NZ     X2,IDCEX    IF INITIAL NOT SIMPLE VARIABLE 
  
 IDC42    SA1    IDCC        GET NESTING LEVEL
          SA2    IDCH        INDEX OF PROCESSING LEVEL
          SA5    IDCD        1ST DO-BEGIN 
          IX1    X1-X2
          =B3    X1-1 
          SA1    X5+B3       FETCH CURRENT DO-BEGIN 
          =X5    -O.DOBI+O.DCBI 
          IX6    X1+X5       CONVERT TO DO-COLLAPSE BEGIN TOKEN 
          SA6    A1 
          AX6    TB.IOIXP 
          SB5    X6          ISOLATE INDEX POINTER
          ERRNZ  18-TB.IOIXL
          =X7    O.EOS
          =A7    B5-1        MARK -EOS- OVER *,* BEFORE INDEX 
          AX6    TB.IOCPP-TB.IOIXP
          SX6    X6 
          ERRNZ  TB.IOCPL-18
          LX6    TB.ICCPP 
          =X5    O.DCCI 
          BX6    X6+X5
          LX2    TB.ICIXP 
          BX6    X6+X2       MAKE DO COLLAPSE CONCLUSION TOKEN
          =A6    B5+DC=CCT
          SA1    IDCINT 
          LX7    X1 
          =A7    A6-DC=CCT+DC=ISV 
          SA2    IDCLMT 
          HX1    TP.BIAS
          AX1    -TP.BIASL   ISOLATE INITIAL
          SA5    IDCI        FETCH COLLAPSE (PRIOR PRODUCT) 
          BX6    X3 
          SA6    IDCQ        SAVE LOWER BOUND 
          IX3    X1-X3       INITIAL - *LB* 
          IX3    X3*X5       * COLLAPSE SIZE = OFFSET 
          LX7    X2 
          HX7    TP.ORD 
          AX7    -TP.ORDL    ISOLATE ORDINAL (FOR POSSIBLE MULTIPLIER)
          BX6    X5 
          SBIT   X2,TP.SHRTP
          PL     X2,IDC45    IF NOT SHORT CONSTANT
          SA5    IDCINT      GET INITIAL
          SBIT   X5,TP.SHRTP
          PL     X5,IDC45    IF NOT SHORT CONSTANT
          LX2    1+TP.SHRTP  RESTORE
          HX2    TP.BIAS
          AX2    -TP.BIASL   ISOLATE LIMIT
          IX1    X2-X1       LIMIT - INITIAL
          =X1    X1+1        +1 = MULTIPLIER
          IX6    X1*X6
          SA6    IDCI        GET COLLAPSE SIZE
  
 IDC45    =A6    A7-DC=ISV+DC=SIZ 
          LX6    X3 
          =A7    A6-DC=SIZ+DC=VAR 
          SA1    IDCA        FETCH ARRAY OPERAND
          MX0    -TP.MODEL
          LX1    -TP.MODEP
          BX1    -X0*X1      ISOLATE MODE 
          SB2    X1-M.DBL 
          =B6    1
          EQ     B2,B0,IDC47 IF MODE DOUBLE 
          EQ     B2,B1,IDC47 IF MODE COMPLEX
          =B6    0
  
 IDC47    LX6    X6,B6       ADJUST BIAS TO MODE
          =A6    A7-DC=VAR+DC=OFF 
          SA2    DATFLG 
          SA7    IDCL 
          NZ     X2,IDC475   IF PROCESSING DATA 
  
*         ADD TO END OF T.IOA (TEMPORARILY) THE *LCI*, 3 WORDS: 
*         CONTROL VAR, INITIAL AND LIMIT TAG WORDS. 
  
          SB6    B3 
          ALLOC  T.IOA,3
          SA1    IDCCV
          SA2    IDCINT 
          SA3    IDCLMT 
          BX6    X1 
          BX7    X2 
          SA6    B7-3 
          BX6    X3 
          =A7    A6+1 
          =A6    B7-1 
          SA1    TL=LCI 
          SX6    X1+3 
          SA6    A1          TL=LCI  =  TL=LCI + 3
          SB3    B6 
          SA1    IDCL 
          BX7    X1 
  
 IDC475   BSS    0
          NZ     B3,IDC48    IF MORE COLLAPSE TO TRY
          SA1    IDCC        NESTING LEVEL
          SA2    IDCG        DIMENSIONALITY 
          IX1    X1-X2
          =B7    1
          ZR     X1,IDC50    IF TRUE COMPLETE COLLAPSE
  
*         WHEN THE DO STRUCTURE COMPLETELY COLLAPSES, BUT THE THE 
*         NESTING LEVEL IS LESS THAN DIMENSIONALITY, A PARTIAL STYLE
*         COLLAPSE IS REQUIRED. 
  
          SA1    IDCD 
          SA2    IDCJ 
          SB4    X1          RESTORE (B4) _ INITIAL DO-BEGIN TOKEN
          SHRINK T=PAR,X2    RESTORE PARSE FILE 
          SA1    IDCA        TP. OF ARRAY 
          BX7    X1 
          =B4    B4-1        RESET TO ALLOW CVL ACCESS TO THE O.DCBI
          SA7    IODOIND     INDICATE PARTIAL COLLAPSE
          SB7    -1 
          EQ     EXIT.
  
*         INCREMENT FOR NEXT COLLAPSE LOOP
  
 IDC48    SA2    IDCB        T.DIM POINTER
          SA1    IDCH        FETCH INDEX OF PROCESSING LEVEL
          SX7    X2+Z=DD
          =X6    X1+1 
          SA7    A2 
          SA6    A1 
          SB3    X6          INDEX FOR NEXT LEVEL 
          SA1    IDCA        FETCH ARRAY TAG
          BX7    X1 
          SA7    IODOIND     INDICATE PARTIAL COLLAPSE
          EQ     IDC30       CONTINUE COLLAPSE PROCESSING 
  
*         COLLAPSE COMPLETE 
*                (B5) = POINTER TO DO COLLAPSE CONCLUSION TOKEN 
*                (X7) = VARIABLE MULTIPLIER 
  
 IDC50    SA1    DATFLG 
          NZ     X1,IDC51    IF *DATA*
          SA1    IDCA 
          BX6    X1 
          =X0    0
          RJ     CML         SEE IF RESTART NEEDED ON ARRAY 
          RJ     PAX         PREPARE ARRAY CROSS-SECTION
  
 IDC51    SA1    IDCINT      GET INITIAL VALUE
          SBIT   X1,TP.SHRTP
          PL     X1,IDC52.1  IF NOT SHORT CONSTANT
          SA1    IDCL        GET VARIABLE MULTIPLIER
          BX7    X1 
          ZR     X1,IDC55    IF NO VARIABLE MULTIPLIER
  
*         THE LAST LIMIT WAS VARIABLE, MUST OUTPUT MULTIPLY TURPLE
  
          SA1    IDCP        GET LENGTH BIAS
          ZR     X1,IDC52    IF NO BIAS 
          BX6    X1 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT OPERAND
          SA4    IDCLMT      GET LIMIT VALUE
          LX5    X6 
  
 IDC51.1  EMIT   V=SUB.I,BOTH 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX6    X6+X2       FORM INDIRECT OPERAND
          SA6    IDCLMT      SAVE AS LIMIT VALUE
          SA1    IDCL        GET VARIABLE MULTIPLIER
          BX7    X1 
  
 IDC52    LX7    TP.ORDP
          =A5    B5+DC=SIZ   FETCH COLLAPSE SIZE
          =X2    X5-1 
          NZ     X2,IDC53    IF SIZE .NE. 1 
          SA5    IDCLMT 
          SA4    IDCA        FETCH ARRAY OPERAND
          EQ     IDC56
  
 IDC52.1  SA1    IDCQ        GET LOWER BOUND
          LX1    42 
          AX1    42          EXTEND SIGN
          BX6    X1 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT OPERAND
          LX5    X6 
          SA4    IDCINT      GET INITIAL VALUE
          EMIT   V=SUB.I,BOTH  EMIT SUBTRACT TURPLE 
          SA1    IDCA        ARRAY OPERAND
          MX0    -TP.MODEL
          BX0    -X0*X1      EXTRACT MODE 
          ERRNZ  TP.MODEP 
          SB7    X0-M.DBL 
          ZR     B7,IDC52.2  IF MODE DOUBLE 
          EQ     B7,B1,IDC52.2  IF MODE COMPLEX 
          EQ     IDC52.3
  
 IDC52.2  SA1    T=PAR
          SX4    X1-Z=TURP
          CLAS=  X0,TP,(INTR),INT 
          LX4    TP.ORDP
          BX4    X4+X0
          LX5    X4 
          EMIT   V=ADD.I,BOTH  DOUBLE SUBSCRIPT FOR COMPLEX AND DOUBLE
  
 IDC52.3  SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR),INT 
          LX6    TP.ORDP
          BX6    X6+X2       FORM INTERMEDIATE OPERAND
          SA6    IDCQ        SAVE AS ARRAY OFFSET 
          SA1    IDCI        GET COLLAPSE SIZE
          SB2    X1 
          EQ     B2,B1,IDC52.6  IF COLLAPSE SIZE=1
          BX6    X1 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT OPERAND
          LX5    X6 
          SA4    IDCQ        GET ARRAY OFFSET 
          EMIT   V=MUL.I,BOTH  ISSUE MULTIPLY TURPLE
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX6    X6+X2       FORM INTERMEDIATE OPERAND
          SA6    IDCQ        SAVE ARRAY OFFSET
  
 IDC52.6  SA1    IDCL        GET VARIABLE MULTIPLIER
          ZR     X1,IDC52.7  IF NO VARIABLE MULTIPLIER
          SA4    IDCLMT      GET LIMIT (BIASED) 
          SA5    CONONE      GET CONSTANT 1 OPERAND 
          EMIT   V=ADD.I,BOTH  EMIT ADD TURPLE
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX4    X6+X2       FORM INTERMEDIATE OPERAND
          SA5    IDCINT      GET INITIAL VALUE
          EQ     IDC51.1     GO ISSUE SUBTRACT TURPLE 
  
 IDC52.7  SA1    IDCLMT      GET LIMIT VALUE (CONSTANT) 
          HX1    TP.BIAS
          AX1    -TP.BIASL
          =X6    X1+1        ADD ONE TO LIMIT 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT OPERAND
          LX4    X6 
          SA5    IDCINT      GET INITIAL VALUE
          EQ     IDC51.1     GO ISSUE SUBTRACT TURPLE 
  
 IDC53    SA5    WO.DOOT     GET MIN. TRIP COUNT
          SA4    IDCLMT      GET VARIABLE MULTIPLIER
          ZR     X5,IDC54    IF ZERO-TRIP DO
          SA5    CONONE      GET CONSTANT ONE 
          EMIT   V=MAX0,BOTH ISSUE MAX0 TURPLE
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX4    X6+X2       FORM INDIRECT OPERAND
  
 IDC54    SA5    B5+DC=SIZ
          BX6    X5 
          =X7    M.INT
          CALL   NCS         FORM CONSTANT OPERAND
          LX5    X6 
          EMIT   V=MUL.I,BOTH 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR) 
          LX6    TP.ORDP
          BX5    X6+X2       MAKE INTERMEDIATE OPERAND
          SA4    IDCA        FETCH ARRAY OPERAND
          EQ     IDC56
  
*         MAKE AND OUTPUT THE I/O DATA TURPLE 
  
 IDC55    SA4    IDCA        FETCH ARRAY OPERAND
          SA5    B5+DC=SIZ   FETCH COLLAPSE SIZE
          LX5    TP.BIASP 
          CLAS=  X2,TP,(SHRT) 
          BX5    X2+X5
  
*                (X4) = ARRAY (TP. FORMAT)
*                (X5) = BLOCK SIZE (TP. FORMAT) 
  
 IDC56    SA1    B5+DC=OFF
          LX1    TP.BIASP 
          BX4    X4+X1       MERGE IN BIAS
          SA1    IDCINT      GET INITIAL VALUE
          SBIT   X1,TP.SHRTP
          MI     X1,IDC565   IF SHORT CONSTANT
          BX6    X5 
          SA6    IDCP        SAVE X5 CONTENTS 
          SA4    IDCA        GET ARRAY
          CLAS=  X5,TP,(ARR)
          BX4    X4+X5       SET ARRAY REF BIT
          SA5    IDCQ        GET ARRAY OFFSET 
          MX0    -TP.MODEL
          BX7    -X0*X4      GET ARRAY MODE 
          LX7    SP.MODEP 
          SA2    ARYOP       GET ARRAY LOAD TURPLE HEADER 
          BX7    X7+X2       MERGE IN ARRAY MODE
          SA7    IOARY
          EMIT   IOARY,*     EMIT ARRAY LOAD TURPLE 
          SA1    T=PAR
          SX6    X1-Z=TURP
          CLAS=  X2,TP,(INTR,ARR,ARS) 
          MX0    -TP.MODEL
          BX4    -X0*X4      GET ARRAY MODE 
          BX2    X2+X4       MERGE IN ARRAY MODE
          LX6    TP.ORDP
          BX4    X6+X2       FORM INDIRECT OPERAND
          SA5    IDCP        RESTORE X5 
  
 IDC565   SA1    IODIR       GET IO DIRECTION 
          SA2    DATFLG 
          NZ     X1,IDC57    IF NOT INPUT DIRECTION 
          NZ     X2,IDC57    IF DATA LIST 
          SA1    IDCA        FETCH ARRAY OPERAND
          BX0    X1 
          SA1    T.SYM
          HX0    TP.ORD 
          AX0    -TP.ORDL    EXTRACT ORDINAL
          SB2    X0 
          LX0    1
          SB2    X0+B2       CONVERT ORDINAL TO INDEX 
          ERRNZ  3-Z=SYM
          SA1    X1+B2       FETCH *WA* 
          ERRNZ  WA.W 
          MX6    WA.SYML
          BX6    X6*X1       SYMBOL ONLY
          SA6    FILL.
          RJ     AII         ADD INPUT LIST ITEM TO T.ILI 
  
 IDC57    SA1    CVLTH
          MX0    -TP.MODEL
          BX2    -X0*X4      ISOLATE MODE 
          ERRNZ  TP.MODEP 
          =A3    A1-CVLTH+CVLPM 
          LX2    SP.MODEP 
          BX7    X1+X2       MERGE IN MODE
          SA7    IODTH
          NZ     X3,IDC58    IF NOT NORMAL I/O PARSEMODE
          EMIT   IODTH,*,T.IOARG
          EQ     IDC59
  
 IDC58    EMIT   IODTH,*
  
 IDC59    SA1    IOREF
          SA2    IDCA        TP. FORMAT OF ARRAY
          HX2    TP.ORD 
          AX2    -TP.ORDL    EXTRACT ORDINAL
          LX2    XR.TAGP     POSITION FOR ERT 
          ADDREF X2,X1
          =X6    0
          SA6    IODOIND
          =A6    A6+1        CLEAR PARTIAL COLLAPSE INDICATORS
          =B7    1           INDICATE COMPLETE COLLAPSE 
          =A1    B4+1 
          NZ     X1,EXIT.    IF NOT *EOS*, I.E., NO TRAILING COMMA
          ERRNZ  O.EOS
          SA1    B4 
          SX1    X1-O.COMMA 
          NZ     X1,EXIT.    IF NOT COMMA 
          SB4    B4+1        INCREMENT FOR DIAGNOSTIC 
          EQ     EXIT.
  
*         COMPLETE COLLAPSE HAS FAILED, SET EXIT CONDITIONS.
  
 IDCEX    BSSENT 0           ENTRY HERE TO STOP COLLAPSE
          SA1    IDCD 
          SA2    IDCJ 
          SB4    X1          RESTORE (B4) _ INITIAL DO-BEGIN TOKEN
          SHRINK T=PAR,X2    RESTORE PARSE FILE 
          SA2    T=REF
          ZR     X2,IDC60    IF T=REF IS ZERO DON'T SHRINK
          SA1    IDCN 
          SHRINK T=REF,X1    AVOID DUPLICATE REFERENCES 
          SA1    IDCO 
          BX6    X1 
          SA6    LOSTREF     RESTORE REFERENCE COUNT
  
 IDC60    SA1    IDCK 
          =B7    0
          =X6    0
          ZR     X1,EXIT.    IF NO T.TB RESTORE 
          SA2    A1+B1       FETCH ORIGINAL TOKEN 
          BX7    X2 
          SA6    A1          CLEAR RESTORATION FLAG 
          SA7    X1 
          EQ     EXIT.
  
 IDCA     BSS    1           SAVE ARRAY TAG 
 IDCB     BSS    1           POINTER TO T.DIM DIMENSION INFORMATION 
 IDCC     BSS    1           I/O DO NESTING LEVEL 
 IDCD     BSS    1           POINTER TO INITIAL DO-BEGIN TOKEN
 IDCE     BSS    1           SUBSCRIPT COUNT
 IDCF     BSS    1           INDUCTION VARIABLE COUNTER 
 IDCG     BSS    1           ARRAY DIMENSIONALITY 
 IDCH     BSS    1           INDEX OF PROCESSING LEVEL
 IDCI     BSS    1           COLLAPSE SIZE
 IDCJ     BSS    1           VALUE OF T=PAR FOR RESET 
 IDCK     BSSZ   1           ADDRESS OF TOKEN TO RESTORE
          BSS    1           CONTENTS 
 IDCL     BSS    1           SAVE VARIABLE MULITIPLIER
 IDCM     BSS    1           ARRAY BASE/BIAS
 IDCN     BSS    1           REFERENCE TABLE COUNT (FOR RECOVER)
 IDCO     BSS    1           REFERENCE COUNT (FOR RECOVER)
 IDCP     BSS    1           LENGTH BIAS
 IDCQ     BSS    1           LOWER BOUND / VARIABLE MULTIPLIER
 TL=LCI   BSS    1           LEN OF *LIST COL. INFO.* APPENDED TO T.IOA 
 IDCIDX   BSS    MAX.DIM+1   INDICES (+ TRASH WORD) 
 IDCIND   BSS    3           INDUCTION VARIABLES
 IDCINT   EQU    IDCIND      INITIAL
 IDCLMT   EQU    IDCIND+1    LIMIT
 IDCINC   EQU    IDCIND+2    INCREMENT
 IDCCV    BSS    1           CONTROL VARIABLE 
 IOD      EJECT 
**        IOD -  MARK OCCURANCES OF IMPLIED DO-LOOPS IN I/O LIST. 
* 
*                BEING A SIMPLE SCHEME FOR DISCOVERING AND MARKING THE
*         EXTENT OF (ANY) IMPLIED-DOS IN AN I/O LIST.  A PSEUDO-STACK 
*         OF PARENTHESES IS KEPT IN THE STRING ITSELF, BY STORING OVER
*         TOP OF EVERY LEFT PAREN THE ADDRESS OF THE PRECEDING ONE. 
*         THIS STACK IS POPPED UP FOR EVERY RIGHT PAREN ENCOUNTERED BY
*         RESETTING THE STACK POINTER (B5) TO THE ADDRESS CONTAINED IN
*         THE LAST LPAREN, AND RESTORING THE LPAREN TO ITS ORIGINAL 
*         VALUE (O.LP).  THUS, WHEN AN EQUAL SIGN IS ENCOUNTERED, THE 
*         TOP OF THE STACK IS ITS OPENING DO-PAREN.  THAT CELL IS 
*         MODIFIED SUCH THAT WHEN THE CLOSING RPAREN IS POPPED, THE 
*         SUPPOSED RESTORATION WILL ACTUALLY TURN IT INTO A DO-BEGIN
*         MARK.  REDUNDANT (NON-DO-IMPLYING) PARENS ARE THEREFORE 
*         EFFECTIVELY IGNORED.
*                AS TRUE DO-IMPLIED PARENS ARE DISCOVERED, WE INSERT
*         *O.EOS* MARKS IN FRONT OF THEM SO THAT THE PARSER WILL LATER
*         STOP THERE AND ALLOW *LST* TO LOOK AT THE DO-BEGIN MARK.
*         THIS IS INHIBITED IF THE LPAREN IS NOT PRECEDED BY A COMMA, 
*         SINCE WHATEVER ELSE IS THERE WILL BE HANDLED BY *LST*, AND NOT
*         THE PARSER. 
*                OF COURSE, ANY LEFT PAREN PRECEDED BY A VARIABLE IS A
*         SUBSCRIPT PAREN, AND IS SKIPPED OVER. 
* 
*         ENTRY  (B4) _ FWA I/O LIST. 
* 
*         EXIT   (B4) = PRESERVED.
*                T.TB = UPDATED.
* 
*         USES   ALL BUT A0, B4.
* 
*         CALLS  ADW, SKS 
* 
*         REGISTER ASSIGNMENTS -- 
*                (A4) _ FETCH ADDRESS.
*                (B5) _ LAST LPAREN LINK. 
*                (B6) = PAREN LEVEL.
  
  
 IOD9     NZ     B6,E.IOD1   IF UNBALANCED PARENTHESIS
          BX6    O.EOS
          SA6    A4          RESET THE EOS FOR PAR
          ADDWD  T.TB        ADD AN EXTRA -EOS- FOR *LST* 
  
 .T       IFNE   TEST        DUMP TOKEN BUFFER
          SA1    CO.SNAP
          LX1    1RN         IMPLIED-LOOP SNAP FLAG 
          PL     X1,IODX     IF (SNAP=N) NOT REQUESTED
          CALL   LTB=        LIST TOKEN BUFFER
 .T       ENDIF 
  
 IOD      SUBR               ENTRY/EXIT...
          SA4    B4          INITIALIZE (A4) = TOKEN CURSOR 
          =B6    0           PAREN LEVEL = 0
          MX4    0
          =B5    B4-1        FAKE UP A LINK TO LAST LPAREN
  
 IOD2     BX3    X4 
          =A4    A4+1 
          =B7    X4-O.LP
          ZR     X4,IOD9     IF *EOS* 
          =B2    B7+O.(-O.) 
          ZR     B7,IOD5     IF *(* 
          ZR     B2,IOD4     IF *)* 
          NE     B2,B1,IOD2  IF NO *=*, LOOP..
          ERRNZ  O.)-O.(-1
          ERRNZ  O.=-O.)-1
  
**        FOUND A *=*  --  MARK CLOSE OF IMPLIED DO.
  
          =X7    A4-1        POINTS TO DO-INDEX 
          ERRNZ  18-TB.IOIXL
          SA3    B5          TOKTOP = T.TB (STACK TOP)
          =X2    O.LP&O.DOBI
          ERRNZ  18-TB.TOTL 
          LX7    TB.IOIXP-TB.TOTP 
          BX0    X7+X2       (0, IOIX, TOT) 
          SA2    A4-2        TOKBE4 = T.TB (*-2)     /* TOK BEFORE INDEX
          LX0    TB.TOTP
          BX7    X3-X0       TOKTOP(IOIX, TOT) = (*-1, O.DOBI)
          SA7    B5 
          SB7    X2-O.COMMA  B7=0 IFF TOKBE4(TOT) = COMMA 
          NZ     B7,E.IOD2   IF IMPLIED DO NOT PRECEEDED BY *,* 
          EQ     IOD2 
  
  
**        FOUND A *)*  --  POP UP PAREN STACK.
  
 IOD4     SA2    B5          TOKOT = T.TB (OLD STACK TOP) 
          MX0    -TB.IOCPL
          SB6    B6-B1       PL = PL - 1
          SX6    B1 
          LX2    -TB.IOCPP
          BX1    X0*X2
          SB5    X2          NEW STACK TOP = TOKTOP(IOCP) 
          LX6    TB.IOSPP 
          MI     B6,E.IOD3   IF TOO MANY RPARENS (RETURN FEC.RNL) 
          SX0    A4          TI = *            /* POINTER TO THIS RPAREN
          BX7    X1+X0       TOKOT(IOCP) = TI 
          IX6    X6+X4       T.TB(TI)(IOSP) = 1      /* MARK DOC RP 
          LX7    TB.IOCPP 
          SA6    A4 
          SA7    A2          T.TB (OLD STACK TOP) = TOKOT 
          EQ     IOD6 
  
  
**        FOUND A *(*  --  PUSH DOWN PAREN STACK. 
*                HOWEVER, IF THIS IS A SUBSCRIPT PAREN (PRECEDING 
*                ELEMENT IS *O.VAR*), SKIP OVER THE SUBSCRIPT AND ANY 
*                PAIRED PARENS WITHIN IT, AND DO NOT MESS UP THE STACK. 
  
 IOD5     BX2    X4 
          HX2    TB.EQL 
          MI     X2,IOD8     IF IMPLIED DO WITHIN THIS PAREN LEVEL
          LX4    -TB.IOCPP
          SA4    X4          SWOOP IMMEDIATELY TO MATCHING RIGHT PAREN
 IOD6     SA2    A4+1 
          ZR     X2,IOD2     IF *EOS* 
          SB2    X2-O.SEP 
          MI     B2,IOD7     IF VARIABLE OR SOME FLAVOR OF CONSTANT 
          SB2    X2-O.LP
          NZ     B2,IOD2     IF NOT *(* 
          SBIT   X2,TB.COLP 
          MI     X2,IOD2     SUBSTRING OK 
 IOD7     SB4    A2+
          EQ     E.IOD4 
  
 IOD8     MX7    -TB.LLPL 
          SX0    B5 
          ERRNZ  18-TB.LLPL 
          LX4    -TB.LLPP 
          BX1    X7*X4       THISTOK(LLP) = 0 
          SB6    B6+B1       PL = PL + 1
          LX1    TB.LLPP-TB.IOCPP 
          IFNE   TB.LLPL,TB.IOCPL,1 
          MX7    -TB.IOCPL
          BX4    X7*X1       THISTOK(IOCP) = 0
          BX7    X4+X0       THISTOK(IOCP) = OLD STACK TOP
          LX7    TB.IOCPP 
          SB5    A4          NEW STACK TOP = HERE 
          SA7    A4          THIS PAREN LINKS BACK TO LAST ONE
          EQ     IOD2 
 C=DOCI   SPACE  4,10 
**        C=DOCI - PROCESS I/O DO COLLAPSE INDUCTION VARIABLES
* 
  
  
 A=DOCI   BSSENT 0           ENTRY... 
          =B4    B4-1 
 C=DOCI   BSSENT 0           ENTRY... 
          MX0    -TP.MODEL
          LX5    -TP.MODEP
          BX0    -X0*X5 
          LX5    TP.MODEP 
          SB2    X0-M.INT 
          ZR     B2,DOCI5    IF VARIABLE IS INTEGER 
          NZ     X0,IDCEX    IF NOT BOOLEAN 
          ERRNZ  M.BOOL 
  
 DOCI5    BX6    X5 
          SA1    IDCF 
          SA2    B4 
          SA6    X1+IDCIND
          SB2    X2-O.COMMA 
          SB3    X2-O.) 
          =B4    B4+1 
          ZR     B3,PAREXIT  IF END OF INDUCTION VARIABLES
          =X6    X1+1 
          NZ     B2,"BLOWUP" IF NOT *,* - ERROR 
          =B2    X6-3 
          PL     B2,IDCEX    IF TOO MANY INDUCTION VARIABLES
          SA6    A1          INCREMENT
          EQ     PAR.NX      PICK UP NEXT INDUCTION VARIABLE
 C=DOCS   SPACE  4,10 
**        C=DOCS - PROCESS I/O DO COLLAPSE SUBSCRIPTS 
* 
*         IF THE TP. RETURNED BY *PAR* IS A SIMPLE INTEGER VARIABLE, THE
*         ORDINAL WILL BE SAVED IN IDCIDX.  OTHERWISE, A STOP COLLAPSE
*         INDICATOR IS STORED.
  
  
 A=DOCS   BSSENT 0           ENTRY... 
          =B4    B4-1 
  
 C=DOCS   BSSENT 0           ENTRY... 
          MX0    -TP.MODEL
          LX2    X5 
          MX6    -0          NON-COLLAPSE INDICATOR 
          LX2    -TP.MODEP
          BX2    -X0*X2      ISOLATE MODE 
          SX2    X2-M.INT 
          NZ     X2,DOCS5    IF NOT INTEGER, STOP COLLAPSE
          BX2    X5*X0       REMOVE MODE
          ERRNZ  TP.MODEP 
          SA1    ="IDCEXC"   FETCH EXCLUSION MASK 
          BX2    X1*X2
          NZ     X2,DOCS5    IF NOT SIMPLE VARIABLE 
          SA1    S=CON
          BX2    X5 
          HX2    TP.ORD 
          AX2    -TP.ORDL    EXTRACT THE ORDINAL
          IX1    X1-X2
          ZR     X1,DOCS5    IF CONSTANT
          CALL   BBC         CONVERT TO BASE/BIAS FORM
          LX6    X5 
  
 DOCS5    SBIT   X5,TP.INTRP
          MI     X5,IDCEX    IF EXPRESSION, NO COLLAPSE 
          LX5    1+TP.INTRP  RESTORE
          SA1    IDCE 
          SA6    X1+IDCIDX   STORE COLLAPSE INDEX INFORMATION 
          SB2    X1          FOR SUBSCRIPT DUPLICATION CHECK
          SA2    IDCG        FETCH NUMBER OF DIMENSIONS 
          IX2    X1-X2
          PL     X2,IDCEX    IF DIMENSIONALITY EXCEEDED 
          =X7    X1+1        INCREMENT SUBSCRIPT COUNT
          SA7    A1 
          SA1    IODIR
          NZ     X1,DOCS10   IF NOT INPUT 
          SA1    IDCM        BASE/BIAS FORM ARRAY 
          BX6    X6-X1
          MX1    -TP.ORDL 
          LX6    -TP.ORDP 
          BX6    -X1*X6 
          ZR     X6,IDCEX    IF INTERFERENCE
  
 DOCS10   BSS    0
          ZR     B2,DOCS12   IF FIRST SUBSCRIPT 
          SB2    B2-1 
          SA1    IDCIDX 
  
 DOCS11   SA2    A1+B2
          IX2    X5-X2
          ZR     X2,IDCEX    IF SUBSCRIPT DUPLICATION 
          SB2    B2-1 
          PL     B2,DOCS11   IF MORE TO CHECK 
  
 DOCS12   BSS    0
          SA2    B4 
          SB2    X2-O.) 
          SB3    X2-O.COMMA 
          =B4    B4+1 
          ZR     B2,PAREXIT  IF SUBSCRIPTS COMPLETED
          =B6    B6-1        REMOVE OPERAND FROM ESTACK 
          ZR     B3,PAR.NX   IF MORE SUBSCRIPTS TO PROCESS
          IFEQ   TEST,ON,1
          EQ     "BLOWUP"    SOMETHING WENT WRONG 
 PAX      EJECT 
**        PAX - PREPARE ARRAY CROSS-SECTION FOR ISSUE.
* 
*         PAX USES THE *LCI* APPENDED TO T.IOA FOR 3 TASKS: 
*         1) CALL *CML* TO DETERMINE IF RESTART IS NEEDED DUE TO
*            A VARIABLE UPPER LIMIT BEING DEFINED PREVIOUSLY IN LIST. 
*         2) ADD ALL CONTROL VARIABLES TO *ILI* (CALL *AII*) SO 
*            THEY ARE MARKED AS DEFINED FOR FUTURE INTERFERENCE.
*         3) EMIT TURPLES TO T.IOLC FOR DEFINING ALL CONTROL VARIABLES. 
*            THESE WILL BE OUTPUT TO *T.PAR* WHEN THE *IOSUB* TURPLE IS 
*            EMITTED (IN *IOJ*).
* 
*         EXIT   *LCI* DEALLOCATED FROM *T.IOA* . 
* 
*         PRESERVES   X5, B4-B6 
  
 PAX      SUBR
          SA4    TL=LCI 
          SA2    T=IOA
          ZR     X4,EXIT.    IF NO *LCI* ON FILE
          MX6    0
          IX7    X2-X4
          SA6    PAXF 
          SA6    PAXG 
          SA7    PAXH        OFFSET FOR *LCI* ON T.IOA
          BX6    X5 
          SA6    PAXD 
          SX7    B6 
          SA7    PAXE 
          SX6    B5 
          IX0    X2-X4
          SA6    PAXA 
          SA2    T.IOA
          IX0    X2+X0
          =A2    X0+2        FIRST LIMIT
          BX5    X4 
  
*         CALL CML ON ANY VARIABLE LIMIT. 
  
 PAX10    BX6    X2 
          SX4    X4-3 
          HX6    TP.SHRT
          SA2    A2+3        NEXT LIMIT 
          PL     X6,PAX20    IF LIMIT IS NOT CONSTANT 
          NZ     X4,PAX10    IF MORE LIMITS 
          EQ     PAX30
  
 PAX20    LX6    TP.SHRTP+1  RESTORE LIMIT
          =X0    1
          RJ     CML         CHECK FOR RESTART
  
 PAX30    SB6    X5 
 PAX40    SA3    T.IOA
          SA1    PAXH 
          SA2    WO.DOOT
          NZ     X2,PAX50    IF DO = OT 
          SA2    PAXG 
          HX2    TP.SHRT
          PL     X2,PAX50    IF LAST LOOP NOT VARIABLE TRIP COUNT 
          MX6    0
          SA6    A2          MARK BRANCH CODE OUT 
  
*         ISSUE BRANCH CODE TO PROTECT INNER CONTROL VARIABLE 
*         DEFINITIONS FROM ZERO TRIP COUNT OF OUTER LOOP, VIZ. DO NOT 
*         REDEFINE I IN 
*         N=0 
*         READ(1)((A(I,J),I=1,10),J=1,N)
  
          SA1    N.GL 
          BX6    X1 
          =X2    1
          =X7    X1+1        N.GL = N.GL + 1
          LX2    TP.GLP 
          SA7    A1 
          LX1    TP.ORDP
          BX6    X1+X2
          BX4    X6 
          SA6    PAXF        SAVE GL OPERAND
          SA5    PAXB        INITIAL
          SA1    OPDUM+O.2ND-O.NONE 
          SX0    V=LCIF 
          LX0    SP.SKELP 
          BX6    X0+X1
          SA6    IODTH
          EMIT   IODTH,*,T.IOLC 
          SA1    OPDUM+O.BOTH-O.NONE
          SX0    V=NOOP 
          LX0    SP.SKELP 
          BX6    X0+X1
          SA6    IODTH
          SA4    PAXC        UPPER LIMIT
          SA5    CONONE      INCREMENT
          EMIT   IODTH,*,T.IOLC 
          SA3    T.IOA
          SA1    PAXH 
  
 PAX50    SB6    B6-3 
          IX3    X3+X1       (T.IOA) + LCI OFFSET 
          SA4    X3+B6       NEXT *CV*
          SA5    CONONE 
          =A3    A4+1        NEXT INITIAL 
          =A2    A3+1        NEXT LIMIT 
          BX6    -X3
          BX7    -X2+X6 
          SA7    PAXG 
          BX6    X3 
          BX7    X2 
          SA6    PAXB 
          SA7    PAXC 
          RJ     AII         ADD CONTROL VARIABLE TO *ILI*
          SA1    OPDUM+O.BOTH-O.NONE
          SX0    V=IOLC 
          LX0    SP.SKELP 
          BX6    X0+X1
          SA6    IODTH
          SA5    PAXB 
          EMIT   IODTH,*,T.IOLC    EMIT FIRST HALF OF IOLC TURPLE 
          SA1    OPDUM+O.BOTH-O.NONE
          SX0    V=NOOP 
          LX0    SP.SKELP 
          BX6    X0+X1
          SA6    IODTH
          SA4    PAXC 
          SA5    CONONE      INCREMENT
          EMIT   IODTH,*,T.IOLC 
          NZ     B6,PAX40    IF MORE ENTRIES
          SA1    TL=LCI 
          SA2    T=IOA
          MX7    0
          IX6    X2-X1
          SA7    A1          TL=LCI  = 0
          SHRINK T=IOA,X6    DEALLOCATE *LCI* 
          SA4    PAXF 
          ZR     X4,PAX60    IF NO PROTECT CODE ISSUED
          MX5    0
          EMIT   OPBSS,*,T.IOLC 
  
 PAX60    SA1    PAXA 
          SB5    X1 
          SA2    PAXD 
          SA3    PAXE 
          BX5    X2 
          SB6    X3 
          EQ     EXIT.
  
 PAXA     BSS    1
 PAXB     BSS    1
 PAXC     BSS    1
 PAXD     BSS    1
 PAXE     BSS    1
 PAXF     BSS    1
 PAXG     BSS    1
 PAXH     BSS    1
 PCI      SPACE  4,10 
**        PCI -  PARSE COLLAPSE ITEMS.
* 
*         CALLS PARSER FOR IDC.  PREFIX TOKEN STRING WITH A SPECIAL LEFT
*         PAREN, TO KEEP PAR HAPPY.  PERTURBED TOKEN RESTORED BEFORE
*         NORMAL EXIT. IF PAR ERROR EXITS, TOKEN MUST BE RESTORED BY
*         CALLER. 
* 
*         ENTRY  (B4) _ TOKEN PRECEDING INTERESTING ONES. 
*                (X4) = ((B4)) = TOKEN TO RESTORE.
*                (X1) = ARGMODE FOR PAR.
  
  
 PCI      SUBR   0           ENTRY/EXIT...
          BX7    X4 
          SX6    B4 
          SA7    IDCK+1      SAVE TOKEN 
          SA6    A7-B1       SAVE ADDRESS 
          SX7    O.SLP
          BX6    X1 
          SA7    B4 
          SA6    ARGMODE
          CALL   PAR         PARSE COLLAPSE ITEMS 
          SA1    IDCK 
          SA2    A1+B1       FETCH ORIGINAL TOKEN 
          MX6    0
          BX7    X2 
          SA6    A1          CLEAR TOKEN RESTORATION FLAG 
          SA7    X1          RESTORE
          EQ     EXIT.
          SPACE  4,10 
          LIST   D
          END 
