*DECK     DATA
          IDENT  DATA 
          TITLE              DATA - PROCESS DATA STATEMENTS 
*CALL     SSTCALL 
  
*         AUTHOR - S.I. JASIK - CDC/SUNNYVALE - JUNE/70 
  
*** 
*         DATA - DATA STATEMENT PROCESSOR 
* 
*         SYNTAX: 
*                DATA <DIL>,...,<DIL> 
*                 WHERE DIL IS A DATA INITIALIZATION LIST 
*                <DIL> := <DVL> / <DIL> / OR ( <DVL> = <DIL> )
*                 WHERE <DVL> IS A DATA VARIABLE LIST 
*                 AND   <DIL> IS A DATA ITEM LIST ( CONSTANTS ) 
*                 THE SECOND SYNTAX WHICH IS NOT ANSI STANDARD IS 
*                 REFERED TO AS THE ALTERNATE SYNTAX .
* 
*         THE SYNTAX OF THE DATA ITEM LIST ( CONSTANTS ) IS:  
* 
*                <DIL> := <DIG>,...,<DIG> 
*                <DIG> := <CONL> OR <RF>*(<CONL>) OR <RF>(<CONL>) 
*                OR (<CONL>) OR <RF>*<CON>
*                <CONL> := <CON>,,,<CON>
*                <CON> := <CONSTANT> OR (<REAL CON>,<REAL CON>) 
*                NOTES: 
*                 (1.,2.) IS A COMPLEX CONSTANT 
*                 2*(1.,2.) # 1.,2.,1.,2. 
*                 2*((1.,2.)) IS 2 COMPLEX CONSTANTS
* 
*         THE SYNTAX OF A DATA VARIABLE LIST IS:  
*                <DVL> := <DVG>,...,<DVG> 
*                <DVG> := <VARNAME> OR <ARRAY>(<CON SUBSC>) 
*                OR <ARRAY> OR <DOLIST> 
*                WHERE: 
*                 <VARNAME> IS THE NAME OF A SIMPLE VARIABLE
*                 <ARRAY> IS THE NAME OF AN ARRAY 
*                 <CON SUBSC> IS A CONSTANT SUBSCRIPT EXPRESSION
*                 OF THE FORM C1,C2,C3
*                 <DOLIST> IS A NEST OF DO LOOPS HAVING THE 
*                 SAME SYNTAX AS THOSE APPEARING IN AN I/O LIST, EXCEPT 
*                 THAT SUBSCRIPTS ARE LIMITED TO THE FORM C1*IVAR+C2
*                 AND ONLY 1 NAME MAY APPEAR IN THE GROUP.
* 
  
 B=DATA   RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
          EXT    ORGTAB,ERPROI,ERPRO,ASAER,DATA.
          EXT    FWAWORK,LWAWORK,RSELECT
          EXT    C.BLOCK,UDATA. 
          EXT    O.DIL,O.DIT,L.DIL,L.DIT
  
 DIM1     EQU    17B
 SELIST   EQU    32B
 PROGRAM  EQU    56B         PROGRAM UNIT TYPE
          EJECT 
*** 
*         ERROR MESSAGE ORDINALS
* 
  
 E.CTO    EQU    36                TABLE OVERFLOW - AN FE ERROR ( ADIT )
 E.PL     EQU    106               DBL VAR MATCH W/ SNGL CON, PREC LOST 
  
 BEN      EQU    112               BASE ERROR NUMBER
  
 E.V>C    EQU    BEN         I     VAR LIST LONGER THAN CON LIST
 E.C>V    EQU    BEN+1       I     CON LIST LONGER THAN VAR LIST
 E.DNA    EQU    BEN+2             NON ANSI FORM OF DATA STMT 
 E.DSE    EQU    BEN+3             SYNTAX ERROR ( IN RAS OR STD ) 
 E.DIL    EQU    BEN+4             SYNTAX ERROR IN ITEM LIST ( BIT )
 E.DIL1   EQU    BEN+5             ILLEGAL ITEM FOLLOWING + OR -
 E.DIL2   EQU    BEN+6             REP LISTS NESTED 2 DEEP
 E.DIL3   EQU    BEN+7             ILLEGAL SEP FOLLOWING DATA ITEM
 E.DCE    EQU    BEN+8             ERROR IN SMALL CONSTANT ( CHKSC )
 E.DVL1   EQU    BEN+9             ILLEGAL SEP AFTER A NAME  ( BVT )
 E.DVL2   EQU    BEN+10            SYNTAX ERROR IN IMPLIED DO NEST
 E.DVL3   EQU    BEN+11            DATA VAR LIST SYNTAX ERROR 
 E.DVL4   EQU    BEN+12            NO MATCH OF LOOP INDEX AND SUBSC VAR 
 E.DVL5   EQU    BEN+13            VAR SUBS APPEARED WITHOUT LOOPS
 E.DVL6   EQU    BEN+14            C1*IVAR+C2 .LT. 1 OR .GT. DIM(I) 
 E.DVL7   EQU    BEN+15            VAR( , VAR NOT DIMENSIONED  ( PSS )
 E.DVL8   EQU    BEN+16            SUBSCRIPT LIST SYNTAX ERROR
 E.DVL9   EQU    BEN+17            A(C1,C2,C3) EXCEEDS STORAGE LIMS 
 E.TRC    EQU    BEN+19      I     CON TO LONG, TRUNCATED      ( ODI )
 E.DVN1   EQU    BEN+20            VAR IS F.P., EXT, FUN, OR // COM 
 E.DVN2   EQU    BEN+21            ILLEGAL NAME APPEARS IN DATA STMT
 E.DNC    EQU    326         DATA VARIABLE NOT DECLARED IN LABEL COMMON 
 E.IHI    EQU    320         I     HOLLERITH CONSTANT .GT. 10 CHARACTERS
 E.DTC    EQU    321         A     VARIABLE/CONSTANT TYPE CONFLICT
          SPACE  2
*** 
*         DATA.E - FE ERROR EXIT
* 
*         ON ENTRY: 
*                B6 = ERROR NUMBER
*                X4 = ELIST ITEM
* 
  
 DTO.E    EREXIT E.CTO             NOT ENOUGH SPACE 
          SA4    =10LPA   DATA
  
 DATA.E   SB7    DATA3             SET RETURN ADDRESS 
          EQ     ERPRO
  
 DATA.N   SA4    SNAME             X4 = NAME OF LAST VARIABLE PROCESSED 
          EQ     DATA.E 
          TITLE              MACROS AND LOCAL VARIABLES 
*** 
*                NON ANSI EXTENSION TO THE DATA STATEMENT:  
* 
*         DO LOOPS AND SUBSCRIPTS OF THE FORM C1*I+C2 
* 
*         A, WHERE "A" IS AN ARRAY IS EQUIVALENT TO (A(I),I=1,PI DIMS)
* 
*         HOLLERITH CONSTANTS MAY BE LONGER THAN ITEM LENGTH ( 1 OR 2 
*         WORDS ).
* 
*         ( VARLIST = DATALIST )  SYNTAX
* 
*         RF*(C1,...,CN) FOR REPETITION OF A LIST OF ITEMS
* 
*         VARIABLES IN LABELED COMMON MAY BE INITIALIZED OUTSIDE A
*         BLOCK DATA SUBPROGRAM.
* 
*         THE RANGE OF AN ARRAY MAY BE EXTENDED BY EQUIVALENCING
*         TO THE LENGTH OF THE EQUIVALENCE CLASS - THE ARRAY BIAS . 
* 
 NONANSI                           NON ANSI USEAGES FLAG
          SPACE  3
 TBITN    MACRO  BIT,LABEL         IF( ^ BIT ) GO TO LABEL
          BX0    X1 
          LX0    59-P.BIT 
          PL     X0,LABEL 
          ENDM
  
*** 
*         BMASK - FORM A BIT MASK OF ELEMENTS IN A SET FOR A LEFT SHIFT 
*         TEST. 
*         EXAMPLE:  
*BITMASK  BMASK  (1RC,1R$,1R*)     BIT MASK FOR C $ AND * 
*         SA1    BITMASK           BIT MASK FOR ELEMENTS
*         SB1    ELEMENT
*         LX1    B1,X1
*         NG     X1,IN.SET         IF ELEMENT IS IN THE SET 
* 
  
          MACRO  BMASK,LOC,P
          USE    MASKS
 LOC      BSS    0
          IRP    P
          POS    60-P 
          VFD    1/1
          IRP 
          POS    0
          BSS    0
          USE    *
          ENDM
          EJECT 
*CALL     PARSEM
*CALL     FMACDEF 
          TITLE              STORAGE AND FLAGS
          USE    /DAT.FMT/
*** 
*         TABLE FORMATS 
* 
* 
*         DIL - DATA INITIALIZATION LIST POINTERS 
*          FORMAT:  24/0,18/FWA OF DVL,18/FWA OF DIL
*         BUILT BY A BACKWARDS SCAN OF THE DATA STATEMENT 
* 
  
 O.CELLS  BSS    0                 FWA OF CONTROL CELLS FOR A LIST
 REPFLAG                           REP FLAG 
 CLOSREP                           CLOSE REP FLAG 
 N.ITEM                            NUMBER OF DATA ITEMS 
 PL                                PAREN LEVEL
  
*         GNI 
  
 I.DIT    BSS    3                 1 - ORDINAL OF NEXT I]EM IN DIT
*                            2 - NUMBER OF ITEMS REMAINING IN REP LIST
*                            3 - ORDINAL OF FIRST DATA I]EM IN REP LIST 
  
 WC.HOL   BSS    1                 HOL. CONSTANT .GT. 1 FLAG
 TC.HOL   BSS    1                 TRUNCATE HOL. FLAG 
 EL.HOL   BSS    1                 ELIST ADDRESS FOR CONSTANT 
 EL.CNS   BSS    1                 ELIST ENTRY FOR CONSTANT 
 LI.HOL   BSS    1                 LAST ISSUE HOLLERITH FLAG
 N.CELLS  EQU    *-O.CELLS
  
 TEMP     BSS    3                 SOME TEMPORARIES 
  
*         BVT 
  
 DVT      BSS    2                 DVT WORDS - SET BY PDV 
 LPINF    BSS    3                 DO LOOP INDEX INFO 
 BIAS                              ACCUMULATED BIAS DUE TO SUBSC CALC 
 LL                                LOWER LIMIT
 UL                                UPPER LIMIT
 INC                               INCREMENT
 SUBN                              NUMBER OF SUBSCRIPT IN ARRAY 
  
*         PSS 
  
 SST      BSS    0
 CON1     BSS    3                 CON1(I) - CONSTANT MULTIPLIERS 
 INDX     BSS    3                 IVAR(I)
 CON2     BSS    3                 CON2(I) - CONSTANT ADDENDS 
 SIGN     BSS    3                 SIGN(I)
 LSST     EQU    *-SST
 N.SUBS                            NUMBER OF SUBSCRIPTS 
 N.VSUB                            NUMBER OF VARIABLE SUBS
          EJECT 
*         MDL 
  
 ORGI                              ORG COUNTER INCREMENT
*                                  = NUMBER OF DATA WORDS PUT OUT BY ODI
  
*         OIC 
  
 B                                 LOCAL COPY OF BIAS 
 DA                                ADDRESS DIFFERENCE 
 T                                 TRIP COUNT 
 MP                                MULTIPLIER ( DA*RL ) 
 RL                                NUMBER OF ITEMS IN A REP LIST
 N                                 NUMBER OF TIMES WE CAN TRAVERSE A
*                                  REP LIST 
 LI       BSSZ   3                 TEMPORARIES USED AS LOOP INDICES 
 TMP      BSS    2                 2 TEMPORARIES
 DLEN     EQU    TMP+1
          USE    *
          SPACE  3
*         PDV 
  
 SNAME                             ELIST OF LAST VARIABLE PROCESSED 
 ORD                               VALUE OF SYMTAB ORDINAL
 SDPF                              0 IF SINGLE PRECISION , 1 IF DOUBLE
 EEL                               EQUIVALENCE EXTENDED LENGTH
*                                  = CLASS LENGTH - ARRAY BIAS
 N.DIMS                            NUMBER OF DIMENSIONS 
 DIM      BSS    3                 DIM1,DIM2,DIM3 
  
 DIM.MUL  DATA   1,0               1 , DIM1 , DIM1*DIM2 
 D1D2                              DIM1*DIM2 ( SET IF N.DIMS = 3 )
  
*         NOTE:  ELEMENTS OF THE ARRAY DIM.MUL ARE FREQUENTLY 
*         REFERED TO AS "DM(J)" . THE DM(J) ARE THE DIMENSIONAL 
*         MULTIPLIERS FOR SUBSCRIPT CALCULATIONS. 
 INFDIAG  BSS    1           FLAG FOR POSTPONED INF DIAG
          TITLE              MAIN LOOP
 DATA     ENTRY.
          RJ     RAS               REMOVE ALTERNATE SYNTAX  (V=C) 
*                                  AND INITIALIZE 
  
 DATA1    SA1    O.DIL
          SX7    -N.CELLS 
          MX6    0
          SA6    O.CELLS           CLEAR OUT CONTROL CELLS
+         SA6    A6+B5
          SX7    X7+B5
          NG     X7,* 
          SA6    L.DIT
  
*         CONVERT THE ITEM LIST TO INTERNAL FORM
  
          SA2    L.DIL
          IX3    X1+X2             TOP OF STACK + 1 
          SA5    X3-1              VAR AND CON LIST POINTERS
          SA4    X5                INITIALIZE FOR CON LIST PROCESSING 
          AX5    18 
          SX6    X5 
          SA6    TMP               SAVE VAR LIST POINTER
          SA5    SELIST 
          RJ     BIT               BUILD DATA ITEM ( CON ) TABLE
  
*         PROCESS THE VARIABLE LIST AND MATCH IT UP WITH THE ITEM LIST
  
          SA3    TMP
          SA5    SELIST 
          BX6    X6-X6
          SA4    X3                INITIALIZE POINTERS
          SA6    I.DIT
          RJ     BVT               PROCESS VARIABLE LIST
  
*         ISSUE INFORMATIVE DIAGNOSTICS IF LISTS NOT THE SAME LENGTH
  
          SA1    LI.HOL 
          SA2    WC.HOL 
          SA3    TC.HOL 
          PL     X1,DATA1A         IF HOLLERITH NOT LAST ISSUE
          ZR     X2,DATA1A         IF NO ILLEGAL HOLL. INITIALIZATION 
          PL     X3,DATA4          IF NO TRUNCATE MESSAGE ISSUED
  
 DATA1A   SA3    N.ITEM 
          SA4    WC.HOL 
          IX5    X3+X4
          ZR     X3,DATA2          IF LISTS MATCH 
          ZR     X5,DATA2          IF INITIALIZED BY DEFAULT
          MI     X3,DATA5          IF MORE VARIABLES THAN CONSTANTS 
          SA1    EL.HOL            GET FIRST UNINITIALIZED CONSTANT 
          SA2    X1 
          BX7    X2 
          SA7    EL.CNS 
          EQ     DATA6             MORE CONSTANTS THAN VARIABLES
  
 DATA2    SA1    L.DIL
          SX6    X1-1              L.DIL = L.DIL - 1
          SA6    A1 
          NZ     X6,DATA1          IF MORE DIL"S TO GO
  
 DATA3    SA1    NONANSI
          BX6    X6-X6
          SA6    L.DIL             FREE ANY TABLE SPACE LEFT
          ZR     X1,DATA           IF NO NON ANSI USEAGES 
          SB6    -E.DNA 
          SB7    DATA              FLAG NON ANSI USEAGES
          EQ     ASAER
  
 DATA4    POSTER NR=E.IHI,SEV=INF,FMT=ELIST,TXT=EL.CNS,RETURN=DATA1A
  
 DATA5    POSTER NR=E.V>C,SEV=INF,FMT=ELIST,TXT=SNAME,RETURN=DATA2
  
 DATA6    POSTER NR=E.C>V,SEV=INF,FMT=ELIST,TXT=EL.CNS,RETURN=DATA2 
          TITLE              RAS - REMOVE ALTERNATE SYNTAX
 EL.LP    EQU    EL.(              LEFT PAREN 
 EL.RP    EQU    EL.) 
 EL.BOS   EQU    EL.EOS            BEGINNING OF STMT MARKER 
 EL.PLUS  EQU    EL.MINUS+1        USED BY BIT TO MAP SIGN INTO -0 OR 0 
  
 SCANTO   MACRO  DELIM
          LOCAL  X
 X        BMASK  (DELIM)
          SA5    X
          RJ     STD
          ENDM
  
          PURGMAC   REPLACE 
 REPLACE  MACRO  OP 
          SX6    OP+2000B 
          LX6    48 
          SA6    A4 
          ENDM
  
*** 
*         RAS - REMOVE ALTERNATE SYNTAX 
*                SCAN DATA STMT BACKWARD AND FORM TABLE OF FWA OF DIL 
*                AND DVL"S. CHANGE DATA INITIALIZATION LISTS OF THE 
*                FORM "( DVL = DIL )" TO "DVL / DIL /" .
*                INITIALIZE TABLE POINTERS, ETC FOR FURTHER PROCESSING. 
* 
*         NOTE:  THIS SUBROUTINE IS A MISTAKE. I ORIGINALLY THOUGHT 
*         THAT ONE COULD FIND THE BEGINNING OF THE CON AND VAR LISTS BY 
*         A SIMPLE BACKWARDS SCAN OF THE STMT. TO SEE THAT THIS IS NOT
*         TRUE CONSIDER:  DATA (A=1),B/2/ . 
*         HENCE THE PRESENT VERSION DISALLOWS INTERMIXING SYNTAXS.
* 
  
 RAS      ENTRY. *
          BX6    X6-X6
          SA6    L.DIT
          SA6    L.DIL             RESET TABLE LENGTHS
          SA2    LWAWORK
          SA3    SELIST 
          SX7    2000B+EL.BOS 
          LX7    48 
          SA7    X3+B5             (SELIST+1) = BEGIN OF STMT OPERATOR
          SA4    X2                A4,X4 = NEXT ITEM PTR AND NEXT ITEM
          MX6    0
          SA6    NONANSI           CLEAR NON ANSI USEAGE FLAG 
  
 RAS1     SA4    A4+B5
          UX1    B2,X4             NEXTE
          IF.NE  EL.SLASH,RAS3     IF NOT A / 
  
*         STANDARD SYNTAX 
  
          SA5    M.SLASH
          RJ     STD         SCAN TO SLASH
          SX7    A4 
          SA7    SW1               SAVE A4
          ADDWD  DIL,X7            ADD THE ADDRESS TO THE DIL 
          SA5    SW1
          SA4    X5                RESTORE A4 
          SA5    M.BOVL 
          RJ     STD         SCAN TO BOS OR SLASH 
          SB6    B5 
          IF.NE  EL.BOS,RAS2       IF NOT BOS 
          SB6    B0 
 RAS2     SX7    A4-B6             POINTER TO BEGIN OF VAR LIST 
          LX7    18 
          BX6    X7+X6             DVL, CON LIST TO DIT 
          SA6    A6                REPLACE THE DIT ENTRY
          SA4    A4-B5             BACKE  1 
          UX1    B2,X4
          ZR     B6,RAS1           IF BOS 
          IF.EQ  EL.COMMA,RAS1     LOOP IF A ,
          BX2    X4          SAVE OFFENDING ITEM
          SA4    A4+B5       BACK TO SLASH
          EQ     RAS.E2 
  
 RAS3     IF.NE  EL.),RAS4         IF NO )
  
*         ALTERNATE SYNTAX - CONVERT TO STANDARD SYNTAX 
  
          REPLACE  EL.SLASH        REPLACE ) WITH / 
          SCANTO EL.=              FIND BEGINNING OF CON LIST 
          SX7    A4 
          SA7    SW1               SAVE A4
          SA7    NONANSI           SET NON ANSI USEAGE FLAG 
          REPLACE  EL.SLASH        REPLACE = "S WITH /
          ADDWD  DIL,X7            ADD TO THE DIL 
          SA5    SW1
          SA4    X5                RESTORE A4 
          SCANTO EL.LP             FIND BEGINNING OF VAR LIST 
          SX7    A4 
          LX7    18 
          BX6    X7+X6
          SA6    A6                REPLACE DIT ENTRY
          SA4    A4+B5
          UX1    B2,X4             NEXTE
          IF.EQ  EL.COMMA,RAS1     LOOP IF A COMMA
          IF.EQ  EL.BOS,RAS        EXIT IF BOS
  
 RAS.E    EREXIT E.DSE             DATA STMT SYNTAX ERROR 
          EQ     DATA.E 
  
 RAS.E2   SA5    M.SLASH
          RJ     STD         SCAN TO SLASH
          SA5    M.BOVL 
          RJ     STD         SCAN TO BOS OR SLASH 
          IF.NE  EL.BOS,RAS.E2     IF MORE LISTS TO PROCESS 
          BX4    X2          ERROR IS MISSING COMMA 
          EQ     BVT.E3      SYNTAX ERROR IN VARIABLE LIST
  
 RAS4     IF.NE  EL.BOS,RAS.E      ERROR IF NOT BOS 
          SA3    L.DIL
          NZ     X3,RAS            IF NOT AN EMPTY DATA STMT
  
 RAS5     EREXIT -E.DSE 
          EQ     DATA.E 
  
 M.SLASH  BMASK  (EL.SLASH) 
 M.BOVL   BMASK  (EL.BOS,EL.SLASH)     BEGINNING OF VARIABLE LIST 
 STD      SPACE  3,4
*** 
*         STD - SCAN TO DELIMETER, PERFORM A PARENTHESIS CHECK
* 
*         ENTRY:  
*                X5 = DELIMETER BIT MASK
*                A4 = FWA-1 OF LIST 
* 
*         EXIT: 
*                A4 = POINTER TO DELIMETER
*                B2 = ELIST OPCODE OF DELIMETER 
* 
 STD      ENTRY. *
  
          SB3    EL.( 
          SB4    EL.) 
          SB6    EL.BOS 
          SB1    B0                B1 = PAREN COUNT 
  
 STD1     SA4    A4+B5
          UX1    B2,X4             NEXTE
          LE     B2,B5,STD1        SKIP CONS AND VARS 
          NE     B2,B4,STD2        IF NOT A ) 
          SB1    B1+B5             PC = PC+1
          EQ     STD1 
  
 STD2     LX3    B2,X5             POSITION DELIMETER MASK
          NE     B2,B3,STD3        IF NOT A ( 
          SB1    B1-B5             PC = PC-1
          PL     B1,STD1           LOOP IF PC \ 0 
          NG     X3,STD            EXIT IF ( IS A DELIMETER 
          EQ     RAS.E             SYNTAX ERROR ( NEGATIVE PAREN COUNT )
  
 STD3     PL     X3,STD4           IF NOT THE DELIM WE WANT 
          ZR     B1,STD            EXIT IF PAREN COUNT = 0
          EQ     RAS.E             GO FLAG ERROR
  
 STD4     NE     B2,B6,STD1        LOOP IF NOT BOS
          EQ     RAS5              GO FLAG THE ERROR
          TITLE              BIT - BUILD DATA ITEM TABLE
*** 
*         BIT - BUILD DATA ITEM TABLE 
*                SCAN THE ITEM LIST AND CONVERT IT INTO INTERNAL FORMAT:  
* 
*                CONSTANTS ARE REPRESENTATED AS:  
*                 1/0,1/HF,18/EA,4/NC,18/IX,18/WC 
*                 WHERE:-    HF - HOLLERITH FLAG. 
*                            EA - ELIST ADDRESS OF ITEM.
*                            NC - HF = 1, NUMBER OF CHARS IN LAST WORD. 
*                                 HF = 0, CONSTANT TYPE.
*                            IX - INDEX.
*                            WC - WORD COUNT. 
*                 FOLLOWED BY WC WORDS OF DATA FOR NON HOLLERITH CONSTAN
*                 FOR HOL CONSTANTS THE NEXT WORD CONTAINS THE ELIST
* 
*                REPETITION COUNTS ARE REPRESENTED AS:  
*                 1/1,5/CIF,18/RL,18/INDEX TO NEXT GROUP,18/REP COUNT 
*                 CIF = 1 OR 2 IF ALL ITEMS ARE THE SAME LENGTH, AND
*                 LENGTH IS 1 OR 2 WORDS , ELSE 0 
*                 RL = NUMBER OF ITEMS IN THE REP LIST
* 
  
 BIT      ENTRY. *
  
 BIT.L    NEXTE                    NEXT ELIST ITEM
          SA3    M.CON
          MX6    0
          LX7    B2,X3
          SA6    WC.HOL            CLEAR HOLLERITH WORD COUNT 
          PL     X7,BIT.E          IF NOT CON + - OR (
          SB1    B2 
          ZR     B1,BIT2           IF A CONSTANT
          SB3    EL.( 
          EQ     B1,B3,BIT6        IF A ( 
  
*         + OR - SIGN 
  
          NEXTE                    NEXT ELIST ITEM
          IF.NE  CON,BIT.E1        IF NO CONSTANT FOLLOWING 
          SX7    B1-EL.PLUS        0 IF + , -1 IF - 
          AX7    1                 0 IF + , -0 IF - SIGN
  
 BIT1     RJ     ADDCON            ADD CONSTANT TO DIT
          SA3    N.ITEM 
          SX6    X3+B5             N.ITEM = N.ITEM+1
          SA6    A3 
          EQ     BIT.S
  
*         CONSTANT
  
 BIT2     SA2    A4-B5             LOOK AHEAD 
          SA3    M.SEP
          UX0    B2,X2
          MX7    0
          LX6    B2,X3
          NG     X6,BIT1           IF NEXT IS , ) OR /
          SA3    REPFLAG
          NZ     X3,BIT.E          IF WE ARE WITHIN A REP LOOP
  
          SX7    B5                SET TO CLOSE ON )
          IF.NE  EL.STAR,BIT3      IF NOT CON*
  
          NEXTE  2                 LOOK PAST *
          IF.EQ  EL.(,BIT4         IF A ( 
          SX7    -B5               SET FOR SINGLE ELEMENT REP 
          EQ     BIT5 
  
 BIT3     IF.NE  EL.(,BIT.E        SYNTAX ERROR IF NOT A (
 BIT4     SA7    NONANSI           SET NON ANSI USEAGE FLAG 
  
 BIT5     SX6    A2+B5             BACKOFF AND SAVE ELIST POINTER 
          SA6    A5 
          SA7    CLOSREP
          RJ     CHKSC             CHECK CONSTANT AND CONVERT 
  
          MX0    1
          BX6    X0+X6             CONSTRUCT ENTRY FOR ADIT 
          SB1    B0 
          RJ     ADIT 
  
          SA1    N.ITEM 
          SA2    L.DIT
          SX6    X2 
          LX1    18 
          BX6    X1+X6
          SA6    REPFLAG           SAVE ITEM COUNT AND POINTER
          MX7    0
          SA7    A1                CLEAR ITEM FLAG
          GETE                     RESTORE REGISTERS
          EQ     BIT.L             AND LOOP TO PROCESS REP LIST 
  
*         ( - START OF A REPEATED DATA LIST OR A COMPLEX CONSTANT 
  
 BIT6     SA1    PL                PARENTHESIS LEVEL
          SA2    CLOSREP
          SX7    X1+B5             PL = PL+1
          SA7    A1 
          IX3    X2-X7
          ZR     X3,BIT.L          IF ( IS A REP BRACKET
  
*         CHECK FOR A COMPLEX CONSTANT
  
          RJ     CFCD              CHECK FOR A COMPLEX CONSTANT 
          ZR     X0,BIT7           IF IT IS 
          SA1    PL 
          AX2    B5,X1
          ZR     X2,BIT.L          IF A MEANINGLESS PAREN 
          EQ     BIT.E2            ERROR - 2 NESTED PAREN GROUPS
  
 BIT7     SA3    DIT.CMPX          DIT HEADER WORD
          SA4    SELIST 
          SX7    X4+4 
          SA4    PL 
          LX7    40 
          BX6    X3+X7
          SX7    X4-1              DECREMENT PAREN COUNT
          SA7    A4 
          SB1    B5+B5
          RJ     ADIT              ADD CONSTANT TO DIT
          SA1    N.ITEM 
          SX6    X1+B5             N.ITEM = N.ITEM+1
          SA6    A1 
          GETE                     POINT PAST ) 
*         EQ     BIT.S             PROCESS SEPERATOR
  
*         PROCESS SEPERATOR AFTER CONSTANT
  
  
 BIT.S    SA1    CLOSREP
          PL     X1,BIT.S1         IF NO SINGLE ELEMENT REP OUTSTANDING 
          RJ     CRL
  
 BIT.S1   IF.EQ  EL.COMMA,BIT.L    LOOP IF A ,
          IF.EQ  EL.SLASH,BIT      EXIT IF A /
          IF.NE  EL.),BIT.E3       ERROR IF NOT A ) 
          MX7    0
          SA7    PL                CLEAR PAREN LEVEL
          SA1    CLOSREP
          ZR     X1,BIT.S2         IF NO REP LIST TO CLOSE
          RJ     CRL               CLOSE IT 
  
 BIT.S2   NEXTE                    NEXT ELEMENT 
          EQ     BIT.S
          SPACE  3
 DIT.CMPX VFD    24/0,18/3,18/2 
 HOL.DIT  VFD    2/1,22/0,18/2,18/0 
 M.SEP    BMASK  (EL.COMMA,EL.RP,EL.SLASH)   , ) AND /
 M.CON    BMASK  (0,EL.LP,EL.MINUS,EL.PLUS)  CON ( + AND -
          SPACE  3
*         BIT ERROR EXITS 
  
 BIT.E    EREXIT E.DIL             SYNTAX ERROR 
          EQ     DATA.E 
  
 BIT.E1   EREXIT E.DIL1            ILLEGAL ITEM FOLLOWING + OR -
          EQ     DATA.E 
  
 BIT.E2   EREXIT E.DIL2            2 NESTED REP LISTS 
          EQ     DATA.E 
  
 BIT.E3   EREXIT E.DIL3            ILLEGAL ITEM FOLLOWING CON 
          EQ     DATA.E 
 CRL      EJECT 
*** 
*         CRL - CLOSE OUT REP LIST
* 
*         ON ENTRY: 
*                A1,X1 = CLOSREP
* 
 CRL2     SX0    B4 
          LX0    54                POSITION ITEM LENGTH 
          BX6    X0+X6
          SA6    A6                STORE UPDATED REP WORD IN DIT
  
 CRL      ENTRY. *
          SA2    REPFLAG
          MX7    0
          SA7    A1                CLEAR FLAGS
          SA7    A2 
  
          SA3    O.DIT
          IX2    X2+X3             ADD DIT BASE TO ORDINAL
          SA1    X2-1              WORD 1 OF REP ENTRY IN DIT 
          SA3    N.ITEM            NUMBER OF ITEMS IN REP LIST
          AX2    18                SAVED TOTAL OF ITEMS 
          SB6    X3                B6 = NUMBER OF ITEMS IN LIST 
          SX0    X1                REMOVE REP FLAG BIT
          IX6    X0*X3             RF * N.ITEMS 
          IX7    X6+X2
          SA7    A3 
  
          LX3    36 
          BX6    X3+X1             ADD NUMBER OF ITEMS TO WORD 1
  
          SA2    O.DIT
          SA3    L.DIT
          IX2    X2+X3
          SX0    A1 
          IX7    X2-X0
          LX7    18                SHIFT INDEX TO NEXT GROUP
          BX6    X7+X6
          SA6    A1                UPDATE WORD 1
  
*         SEARCH FOR AND MARK REP LISTS WHERE ALL ITEMS ARE THE SAME
*         LENGTH AND LENGTH = 1 OR 2 .
  
          SA2    A1+B5
          SB4    X2                NUMBER OF WORDS IN FIRST ITEM
          SB3    B4-B5
          GT     B3,B5,CRL         IF WC > 2
  
 CRL1     AX2    18 
          SB6    B6-B5
          ZR     B6,CRL2           IF END OF REP LIST 
          SB3    X2 
          SA2    A2+B3
          SB3    X2 
          EQ     B3,B4,CRL1        LOOP IF ITEMS HAVE THE SAME LENGTH 
          EQ     CRL
 CFCD     EJECT 
*** 
*         CFCD - CHECK FOR COMPLEX DATA ITEM
* 
*         ON ENTRY: 
*                A4 - POINTS TO ( 
* 
*         ON EXIT:  
*                X0 = 0 IF A COMPLEX CON IS DETECTED AND
*                X1,X2 = REAL AND IMAGINARY PARTS OF CONVERTED CONSTANT 
*                SELIST POINTER UPDATED TO POINT PAST ) 
*                X0 " 0 IF NOT AND A4,X4 UNTOUCHED
* 
  
 CFCD     ENTRY. ** 
          SA3    A4-B5
          MX0    1                 SET FOR FAILURE
          UX1    B2,X3
          MX7    0                 SET FOR + SIGN 
          SB4    B2-EL.MINUS
          EQ     B4,B5,CFCD1       IF + 
          NZ     B4,CFCD2          IF NOT - 
          MX7    60 
 CFCD1    NEXTE  3                 NEXT ITEM
 CFCD2    IF.NE  CON,CFCD          EXIT IF NOT A CON
          AX1    45 
          BX6    X3 
          SX2    X1-T.REAL
          NZ     X2,CFCD           IF NOT A REAL CONSTANT 
          NEXTE  3
          IF.NE  EL.COMMA,CFCD     IF NOT A , 
          SA6    TEMP              SAVE ELIST FOR REAL PART 
          SA7    A6+B5             AND SIGN 
          NEXTE  3
          MX7    0
          IF.EQ  EL.PLUS,CFCD3     IF A + 
          IF.NE  EL.MINUS,CFCD4    IF NOT - 
          MX7    60 
 CFCD3    NEXTE  3
 CFCD4    IF.NE  CON,CFCD          IF NOT A CONSTANT
          AX1    45 
          SX2    X1-T.REAL
          NZ     X2,CFCD           IF NOT A REAL CONSTANT 
          NEXTE  3
          IF.NE  EL.),CFCD         IF NO )
  
          SX6    A3-B5
          SA6    SELIST      SUCCESS, UPDATE ELIST POINTER
          SA1    TEMP              CON
          SA7    A1                SAVE SIGN OF SECOND
          SB1    -B5
          CALL   CONVERT           CONVERT REAL PART TO BINARY
          SA2    TEMP+1            SIGN OF FIRST
          BX6    X1-X2
          SA6    A2                SAVE REAL PART 
          SA3    SELIST 
          SA1    X3+2              IMAGINARY PART 
          SB1    -B5
          CALL   CONVERT
          SA3    TEMP 
          BX2    X1-X3             ADD SIGN 
          SA1    A3+B5             REAL PART
          MX0    0                 SET FLAG 
          EQ     CFCD 
 CHKSC    SPACE  3
*** 
*         CHKSC - CHECK SMALL CONSTANT
*                CHECKS CONSTANT FOR PROPER TYPE (INTEGER OR OCTAL )
*                AND MAGNITUDE ( 0 < CON < 2**17 )
* 
*         ON ENTRY: 
*                X4 = ELIST FOR CONSTANT
* 
*         ON EXIT:  
*                X6 = CONVERTED CONSTANT
* 
  
 CHKSC    ENTRY. *
          UX6    X4 
          SA6    TEMP 
          AX6    45                POSITION TYPE FIELD
          SB2    X6 
          EQ     B2,B5,CHKSC1      IF TYPE INTEGER
          SB3    B2-T.OCT 
          NZ     B3,CHKSC.E        IF NOT OCTAL 
  
 CHKSC1   SB1    -B5
          BX1    X4 
          CALL   CONVERT
          BX6    X1 
          AX1    17 
          ZR     X6,CHKSC.E        IF 0 
          ZR     X1,CHKSC          EXIT IF .LT. 2**17-1 
  
 CHKSC.E  EREXIT E.DCE             CON NOT TYPE INTEGER OR OCT OR 
          SA3    TEMP              CON = 0 OR .GT. 2**17-1
          PX4    X3 
          EQ     DATA.E 
 ADDCON   EJECT 
*** 
*         ADDCON - ADD CONSTANT TO "DIT"
* 
*         ON ENTRY: 
*                X1,X4,A4,A5 SET UP TO CONSTANT BY MACRO "NEXTE"
*                X7 = -0 IF CON PRECEEDED BY - SIGN , ELSE 0
* 
*         ON EXIT:  
*                X1,X4,A4,A5 RESTORED BY A CALL TO MACRO "GETE" 
* 
  
 ADDCON1  SX6    X1 
          SA6    TEMP              SAVE CONSTANT TYPE 
          SA7    A6+B5             AND SIGN 
          BX1    X4 
          CALL   CONVERT           CONVERT TO BINARY
          SA3    TEMP 
          SA4    A3+B5             SIGN 
          BX1    X1-X4
          SX7    X3-T.DBL 
          SX6    B5                WORD COUNT 
          LX3    36          POSITION CONSTANT TYPE 
          SA7    A3          RESET TEMP 
          NZ     X7,ADDCON2  IF NOT DOUBLE
          SX6    B5+B5             WC = 2 
          BX2    X2-X4
 ADDCON2  SX0    X6+B5             INDEX = WC+1 
          BX6    X6+X3       ADD IN CONSTANT TYPE 
          LX0    18 
          SA3    EL.HOL            SET ELIST POINTER IN BIT FIELD 
          BX6    X0+X6
          LX3    40 
          SB1    X6                WORD COUNT FOR ADIT
          BX6    X6+X3
  
 ADDCON3  RJ     ADIT              ADD X6,X1 AND X2 TO CON TABLE
          GETE                     RESTORE REGISTERS
 ADDCON   ENTRY. *
          UPDATE
          AX1    45                POSITION CON TYPE
          SB1    -B5
          SX2    X1-T.HOL 
          SX6    A4                STORE ELIST ADDRESS TEMPORARILY
          SA6    EL.HOL 
          NZ     X2,ADDCON1        IF NOT HOLLERITH 
  
          BX1    X4                PROCESS HOLLERITH CONSTANT 
          AX4    18 
          SB1    9
          SX2    X4+B1
          SX0    B1+B5
          SA3    HOL.DIT           DIT HEADER WORD
          IX2    X2/X0             WC = (CC+9)/10 
          SB7    X7-0 
          SX7    A4 
          BX6    X3+X2
          LX7    40 
          BX6    X6+X7
          SX7    X2-1 
          SX4    X4                CHAR COUNT 
          SX0    B1+B5
          SA7    WC.HOL            SET WC.HOL FLAG
          IX2    X0*X2
          IX5    X4-X2             CC-10*WC 
          SB1    B5 
          MI     B7,ADDCONH        IF CON IS PRECEDED BY A - SIGN 
          ZR     X5,ADDCON3        IF CC IS A MULTIPLE OF 10
          SX5    X5+10D 
          LX5    36 
          BX6    X5+X6             SAVE NUMBER OF CHARS IN LAST WORD
          EQ     ADDCON3
  
*         -CON - COMPLEMENT CONSTOR ENTRY AND ADJUST LAST WORD
  
 ADDCONH  SB2    X1                FWA OF CON 
          BX4    X1 
          SB3    B2+X6             LWA+1
          MX0    60-2        MASK FOR ONLY PART OF TYPE FIELD 
+         SA2    B2 
          BX7    -X2
          SB2    B2+B5             I = I+1
          SA7    A2 
          LT     B2,B3,*-1
          ZR     X5,ADDCON3        IF NO PARTIAL WORD 
  
          AX4    36 
          BX3    -X0*X4            HOL TYPE 
          ZR     X3,ADDCON3        IF H FORMAT
          SX5    X5+10D 
          LX5    1
          SB4    X3 
          LX7    B5,X5
          MX0    1
          IX4    X5+X7             6*CHAR IN LAST WORD
          SB3    X4-1 
          AX0    B3,X0
          BX2    X0*X2             REMOVE TRAILING BLANKS 
          EQ     B4,B5,ADDCONH1    IF L FORMAT
          SB3    B3+B5
          LX2    B3,X2             R FORMAT - RIGHT JUSTIFY LAST WORD 
 ADDCONH1 BX7    -X2
          SA7    A7 
          EQ     ADDCON3
          SPACE  3
*** 
*         ADIT - ADD WORDS TO DIT TABLE 
* 
*         ON ENTRY: 
*                X6,X1,X2 = WORDS TO BE ADDED 
*                B1 = NUMBER OF WORDS - 1 TO BE ADDED 
*                X6 IS ALWAYS ADDED 
* 
  
 ADIT     ENTRY. *
          BX7    X1 
          SA7    SW1               SAVE WORD 2
          BX1    X6                SETUP FOR ADDWD CALL 
          LX6    X2 
          SA6    SW2               SAVE WORD 3
          SX7    B1 
          SA7    SW3               SAVE WORD COUNT
          ADDWD  DIT               ADD THE FIRST WORD TO THE DIT
          SA2    SW3
          ZR     X2,ADIT           IF ONE WORD TO ADD 
          SA1    SW1
          ADDWD  DIT               ADD 2ND WORD TO DIT
          SA2    SW3
          AX2    1
          ZR     X2,ADIT           IF 2 WORDS REQUESTED 
          SA1    SW2
          ADDWD  DIT               ADD WORD 3 TO DIT
          EQ     ADIT 
  
          USE    /MACBUF/ 
 SW1      BSS    1                 SAVED WORDS FOR ADIT 
 SW2      BSS    1
 SW3      BSS    1
          USE    *
          TITLE  BVT - PROCESS DATA VARIABLE LIST 
*** 
*         BVT - PROCESS DATA VARIABLE LIST
*                SCANS DATA VARIABLE LIST AND BUILDS A "DVT" ENTRY FOR
*                ITEM, FORMAT:  
* 
*         1/0,1/SDPF,1/ORGF,1/DDD,14/0,6/CTYP,18/SYMORD,18/EQUIV BIAS 
*         24/0,18/LENGTH,18/ITEM COUNT
* 
*                WHERE: 
*                 SDPF = 0 IF SINGLE PRECISION , ELSE 1 
*                 ORGF = 1 IF WE ISSUED STORAGE IN DPCLOSE FOR THE VAR
*                 DDD = 1 IF PREVIOUS APPEARENCES IN A DATA STMT
*                 LENGTH = AMOUNT OF STORAGE ASSIGNED TO THE VAR
*                 ITEM COUNT = NUMBER OF ITEMS
* 
*                IN THE CASE THAT EXPLICIT DO LOOPS APPEAR, THEY ARE
*                REDUCED TO THE FORM: 
*                 6/P,18/M(P),18/T(I),18/DIM(P) 
*                (((A(M1*I1,M2*I2,M3*I3),I = 1,T1),J = 1,T2),K = 1,T3)
*                WHERE I1 I2 I3 IS SOME PERMUTATION OF I,J AND K .
*                THE ADDITIONAL BIAS IS STORED IN THE BIAS FIELD
*                AND SUBSCRIPT WORDS OF THE FORM: 
*                ARE APPENDED, WHERE: 
*                 P = ORDER OF APPEARENCE IN SUBSCRIPT EXPR 
*                 M(P) = MULTIPLIER 
*                 T(I) = UPPER LIMIT = TRIP COUNT FOR LOOP
*                 DIM(P) = P"TH DIMENSION OF THE ARRAY
* 
* 
*         IF THE DATA VARIABLE LIST IS LONGER THAN THE DATA ITEM LIST,
*         -BVT- RETURNS TO THE CALLER AFTER ISSUING AN INFORMATIVE
*         DIAGNOSTIC.  N.ITEM IS ZEROED TO PREVENT ISSUING THE MESSAGE
*         -VAR LIST .GT. CON LIST- TWICE.  THE -DATA.- BLOCK LENGTH IS
*         NOT INCREMENTED, NOR IS STORAGE ISSUED TO -COMPS-, FOR THOSE
*         VARIABLES WITHOUT MATCHING DATA ITEMS.  ON EXIT, -SELIST- HAS 
*         NOT BEEN UPDATED TO SKIP OVER THE UNMATCHED VARIABLES IN
*         E-LIST.  STATEMENT PROCESSING MAY BE RESUMED AT THE NEXT
*         VARIABLE/CONSTANT SUBLIST PAIR BY FETCHING THE NEXT -DIL- 
*         TABLE ENTRY, WHICH WILL CONTAIN THE FWA OF THE NEXT VARIABLE
*         LIST STRING IN E-LIST.
  
 P.SDPF   EQU    58                SINGLE/DOUBLE PRECISION FLAG 
 P.ORGF   EQU    57                ORG/NO ORG FLAG
 P.DDD    EQU    56                SECOND DEFINITION IN A DATA STMT 
 P.LCMI   EQU    55          LCM INDIRECT ADD. FLAG 
 P.SYMORD EQU    18                SYMTAB ORD IN BITS 18-35 
 P.CTYP   EQU    36          CONSTANT TYPE FIELD POSITION 
  
 BVT      ENTRY. *
  
 BVT1     NEXTE                    NEXT ELEMENT 
          SA3    N.ITEM 
          MX6    0
          SB7    X3 
          SA6    BIAS 
          SA6    N.VSUB 
          IF.NE  NAME,BVT3         IF NOT A NAME
          LE     B7,B0,BVT.E10     IF MORE DATA VARS THAN CON LIST ITEMS
          RJ     PDV               PROCESS NAME 
          SA3    M.SEP1            , / OR ( 
          LX7    B2,X3
          PL     X7,BVT.E1         IF ILLEGAL ITEM FOLLOWING NAME 
          IF.EQ  EL.(,BVT1A        IF NAME( 
          SA3    N.DIMS 
          ZR     X3,BVT2           IF A SIMPLE VARIABLE 
          SA7    NONANSI           SET NON ANSI USEAGE FLAG 
          EQ     BVT2 
  
*         PROCESS A(C1,C2,C3) 
  
 BVT1A    RJ     PSS               PROCESS SUBSCRIPT LIST 
          NZ     B7,BVT.E5         IF VARIABLE SUBS APPEARED
  
*         COMPUTE BIAS OF A(C1,C2,C3) 
  
          SA2    N.SUBS 
          SA1    CON2 
          SB1    X2 
          SB3    -B5               B3 = -1
          SX6    X1+B3             C1-1 
          EQ     B1,B5,BVT1B       IF ONLY 1 SUBSCRIPT
          SA1    A1+B5             C2 
          SA2    DIM.MUL+1         DIM1 
          SB1    B1-B5
          SX1    X1+B3             C2-1 
          IX3    X2*X1             DIM1*(C2-1)
          IX6    X3+X6
          EQ     B1,B5,BVT1B       IF 2 SUBS
          SA1    A1+B5             C3 
          SA2    A2+B5             DIM1*DIM2
          SX1    X1+B3
          IX3    X2*X1             DIM1*DIM2*(C3-1) 
          IX6    X3+X6
 BVT1B    SA3    SDPF 
          SB3    X3 
          LX6    B3,X6             *2 IF 2 WORDS /ENTRY 
          SA6    BIAS 
  
 BVT1C    SA2    DVT+1             ADJUST SECOND WORD OF DVT ENTRY
          AX2    18                WORD LENGTH OF ARRAY 
          IX2    X2-X6             REDUCE BY BIAS 
          NG     X2,BVT.E9         IF LOCF(A(C1,C2,C3)) IS OUT OF RANGE 
          ZR     X2,BVT.E9   IF OUT OF RANGE
          LX2    18                (FOR PROPER HANDLING OF HOLLERITH CON
          SX0    B5                SET ITEM COUNT = 1 
          BX6    X0+X2
          SA6    A2 
          GETE                     GET SEPERATOR
          IF.EQ  EL.COMMA,BVT2     IF A , 
          IF.NE  EL.SLASH,BVT.E1   IF NO /
  
 BVT2     SX5    B0 
          RJ     MDL               MATCH UP LISTS 
          GETE                     RESTORE SEPERATOR
          IF.NE  EL.SLASH,BVT1     LOOP IF NOT END OF VAR LIST
          EQ     BVT
  
*         PROCESS EXPLICIT DO LOOPS 
  
 BVT3     IF.NE  EL.(,BVT.E3       IF NO (
          SX7    B0 
 BVT4     NEXTE                    NEXT ELIST ELEMENT 
          SX7    X7+B5             INCREMENT PAREN COUNT
          EQ     B2,B3,BVT4        LOOP IF A (
          IF.NE  NAME,BVT.E3       ERROR IF NEXT IS NOT A NAME
          LE     B7,B0,BVT.E10     IF MORE DATA VARS THAN CON LIST ITEMS
          SA7    PL                SAVE PAREN LEVEL 
          SA7    NONANSI           SET NON ASNI USEAGE FLAG 
          RJ     PDV               PROCESS ARRAY NAME 
          IF.NE  EL.(,BVT.E2       ERROR IF NOT NAME( 
          RJ     PSS               PROCESS SUBSCRIPT LIST 
          SA1    PL 
          SB6    X1 
          GT     B7,B6,BVT.E2      ERR IF MORE VARIABLE SUBS THEN LOOPS 
  
*         SYNTAX CHECK DO INDICES AND CONVERT LOOP TO CANONICAL FORM
  
          SB1    B0                LOOP INDEX 
          MX6    0
          SA6    N.VSUB            CLEAR LOOP COUNTER 
  
 BVT5     GETE
          IF.NE  EL.COMMA,BVT.E2   IF NO ,
          NEXTE 
          IF.NE  NAME,BVT.E2       IF NO INDEX VARIABLE 
  
*         SEARCH SUBSCRIPT TABLE FOR MATCH OF INDEX VARIABLE
  
          SA2    N.SUBS 
          SB2    B0                INDEX
          SB3    X2                LIMIT
 BVT6     SA3    INDX+B2           SUBSCRIPT VARIABLE 
          SB2    B2+B5             P = P+1
          IX5    X4-X3
          ZR     X5,BVT7           IF A MATCH 
          LT     B2,B3,BVT6        IF MORE SUBS TO GO 
          EQ     BVT.E4            IF LOOP INDEX DOESN"T MATCH SUBSC VAR
  
 BVT7     SX6    B1+B5
          SA6    A3                INDX(P) = I
          SX7    B2-B5
          SA7    SUBN              SUBN = P 
  
          NEXTE 
          IF.NE  EL.=,BVT.E2       IF NO = SIGN 
          NEXTE 
          IF.NE  CON,BVT.E2        IF NO LOWER LIMIT
          BX6    X4 
          SA6    LL 
          NEXTE 
          IF.NE  EL.COMMA,BVT.E2   IF NO ,
          NEXTE 
          IF.NE  CON,BVT.E2        IF NO UPPER LIMIT
          BX6    X4 
          SA6    UL 
          NEXTE 
          MX6    0
          SA6    INC
          IF.NE  EL.COMMA,BVT8
          NEXTE 
          IF.NE  CON,BVT.E2        IF NO INCREMENT
          BX6    X4 
          SA6    A6                SAVE INCREMENT 
          NEXTE 
 BVT8     IF.NE  EL.),BVT.E2       IF NO )
          UPDATE                   SAVE ELIST POINTER 
  
          SA4    LL 
          RJ     CHKSC             CONVERT LOWER LIMIT
          SA6    LL 
          SA4    UL 
          RJ     CHKSC             CONVERT UPPER LIMIT
          SA6    UL 
          SA4    INC
          SX6    B5 
          ZR     X4,BVT9           IF NO INCREMENT
          RJ     CHKSC             CONVERT
 BVT9     SA6    INC
  
*         TEST FOR LOWER LIMIT OF SUBSCRIPT OUTSIDE OF DIM RANGE
  
          SA5    SUBN 
          SB2    X5                B2 = J 
          SA1    CON1+B2           CON1(J)
          SA2    LL 
          SA3    CON2+B2           CON2(J)
          IX0    X1*X2
          IX7    X0+X3             X7 = V = C1*LL+C2
          SX6    X7-1 
          NG     X6,BVT.E6         IF SUBSC VALUE < 1 
  
*         TEST FOR DEGENERATE LOOP ( A 1 TRIP LOOP )
  
          SA5    N.VSUB 
          SA1    UL 
          SB1    X5                B1 = LOOP NUMBER 
          SX2    X2                LL 
          IX0    X2-X1             LL-UL
          PL     X0,BVT10          IF DEGENERATE ( LL \ UL )
  
          SA3    INC
          IX0    X3-X0             UL-LL+INC
          IX6    X0/X3             TRIP COUNT = X0/INC
          SB6    X6 
          NE     B6,B5,BVT11       IF NOT DEGENREATE
  
*         1 TRIP LOOP - CHANGE TO CONSTANT SUBSCRIPT
  
 BVT10    MX6    0
          SA6    INDX+B2           INDX(J) = 0
          SA7    CON2+B2           CON2(J) = V
          EQ     BVT12
  
*         NORMAL CASE - ADJUST C1 AND C2  SO LOOP TAKES THE FORM
*                ( A( ,C1*I+C2, ) , I = 1,TC )
  
 BVT11    SA1    INC
          SA2    CON1+B2
          SA3    CON2+B2
          SA4    LL 
          IX5    X4-X1
          IX6    X1*X2
          SA6    A2                C1 = C1*INC
          IX4    X2*X5
          IX7    X3+X4
          SA7    A3                C2 = C2+C1*(LL-INC)
  
*         COMBINE AND STORE P, C1(P) , TC AND DIM(P) IN LPINF(I)
  
          LX6    36                C1 
          SA4    DIM+B2 
          BX6    X4+X6
          SX0    B2                P
          LX0    54 
          BX6    X0+X6
          SX7    B6                TC 
          LX7    18 
          BX6    X7+X6
          SA6    LPINF+B1          SAVE SUBSCRIPT INFO
          SX7    B1+B5
          SB1    B1+B5
          SA7    N.VSUB            ADVANCE INDEX AND SAVE 
  
*         ADJUST BIAS TO ELIMINATE CONSTANT ADDEND ( C2(J) )
  
          SA1    BIAS 
          SA2    DIM.MUL+B2        DIM.MUL(J) 
          SA3    CON2+B2
          SA5    SDPF 
          SB4    X5 
          IX4    X2*X3
          LX5    B4,X4             *2**SDPF 
          IX6    X5+X1             BIAS = BIAS+DIM.MUL(J)*C2(J)*2**SDPF 
          SA6    A1 
  
 BVT12    SA5    PL 
          SX6    X5-1 
          SA6    A5                PL = PL-1
          NZ     X6,BVT5           LOOP IF MORE TO GO 
  
*         ADD TO THE BIAS THE CONTRIBUTION DUE TO CONSTANT SUBSCRIPTS 
*         I.E. - A( ,C2, )
  
          SA2    N.SUBS 
          SA3    SDPF 
          SA5    BIAS 
          SB1    B0                INDEX
          SB2    X2                LIMIT
          SB4    X3                SDPF 
          SB3    -B5               -1 
          BX6    X5 
  
 BVT13    SA1    INDX+B1
          NZ     X1,BVT14          IF A DO INDEXED SUBSCRIPT
          SA2    CON2+B1
          SA3    DIM.MUL+B1 
          SX2    X2+B3
          IX4    X3*X2
          LX5    B4,X4
          IX6    X5+X6             BIAS = BIAS+DM(I)*(C2(I)-1)*2**SDPF
 BVT14    SB1    B1+B5
          LT     B1,B2,BVT13       IF MORE TO GO
          SA6    A5                UPDATE BIAS
  
*         COLLAPSE INNERMOST LOOPS IF THE SUBSCRIPTS ARE IN STANDARD
*         ORDER ( IJK ) 
  
          SA2    N.VSUB            NUMBER OF LOOPS
          ZR     X2,BVT1C          IF ALL LOOPS ARE DEGENERATE
          SB1    B0                INDEX
          SB2    X2                LIMIT
          EQ     B2,B5,BVT18       IF ONLY 1 LOOP 
  
 BVT15    SA1    LPINF+B1          LOOP INFORMATION WORD
          SX4    X1                DIM(P) 
          AX1    18 
          SX3    X1                TC 
          AX1    18 
          SB3    X1                M
          AX1    18 
          SB4    X1                P
          NE     B4,B1,BVT18       IF NOT IJK ORDER 
          NE     B3,B5,BVT17       IF M " 1 
          IX5    X3-X4
          SB1    B1+B5
          NG     X5,BVT17          IF TC < DIM
          LT     B1,B2,BVT15
  
*         SUCCESS - REDUCE TO A SINGLE LOOP 
  
 BVT16    SA1    LPINF-1+B2        LAST LOOP INFO WORD
          SA2    DIM.MUL-1+B2 
          AX1    18 
          SX1    X1                TC FOR LAST LOOP 
          IX3    X1*X2
          SA4    DVT+1
          SX4    X4                PI DIMS
          SX7    B5 
          SA7    N.VSUB            NUMBER OF LOOPS
          LX3    18 
          BX6    X3+X4
          LX7    36                M = 1
          IX7    X7+X6
          SA7    LPINF             UPDATE LOOP INFO WORD
          EQ     BVT18
  
*         PARTIAL SUCCESS - COLLAPSE INNERMOST LOOPS
  
 BVT17    LE     B1,B5,BVT18       IF WE CAN"T COLLAPSE AT LEAST 2 LOOPS
          EQ     B1,B2,BVT16       IF COMPLETE REDUCTION
  
          SA1    LPINF             MERGE FIRST AND SECOND LOOPS 
          SA2    A1+B5
          AX1    18 
          SX1    X1 
          AX2    18 
          SX2    X2 
          IX3    X1*X2             TC1*TC2
          SX7    B5 
          LX7    36                M = 1
          SA4    DIM.MUL+2         DIM1*DIM2
          LX3    18 
          BX6    X3+X4
          IX7    X7+X6
          SA7    A1                UPDATE FIRST LOOP INFO WORD
          SX6    B2-B5
          SA6    N.VSUB            UPDATE N.VSUB
          SA5    A2+B5
          BX7    X5                MOVE LAST LOOP INFO WORD DOWN
          SA7    A2 
  
*         COMPUTE A(M1*T1,M2*T2,M3,T3) AND SEE IF IT IS WITHIN
*         THE ARRAY BOUNDS
  
 BVT18    SA5    N.VSUB            NUMBER OF LOOPS
          SB1    B0                INDEX
          SB2    X5                LIMIT
          SA4    SDPF 
          SB3    -B5               B3 = -1
          SB4    X4                B4 = SDPF
          SA3    BIAS 
          AX6    B4,X3
  
 BVT19    SA4    LPINF+B1 
          AX4    18 
          SX1    X4                T(I) 
          AX4    18 
          SX2    X4                M(I) 
          AX4    18                P
          SA3    DIM.MUL+X4        DM(P)
          IX0    X1*X2
          SX1    X0+B3             M*T-1
          IX2    X3*X1             DM*( M*T-1 ) 
          IX6    X2+X6
          SB1    B1+B5
          LT     B1,B2,BVT19       IF MORE TO GO
          LX6    B4,X6             *2**SDPF 
          SA2    DVT+1
          AX2    18                ARRAY LENGTH 
          IX3    X6-X2             BIAS - LEN 
          NG     X3,BVT20          IF IN RANGE
          SA4    EEL               EQUIV EXTENDED LENGTH
          IX7    X6-X4
          PL     X7,BVT.E6         IF OUT OF RANGE
          SX7    B5 
          SA7    NONANSI           SET NON ANSI USEAGE FLAG 
  
 BVT20    RJ     MDL               MATCH UP LISTS 
          GETE                     SEPERATOR
          IF.EQ  EL.COMMA,BVT1     LOOP FOR NEXT IF A , 
          IF.EQ  EL.SLASH,BVT 
          EQ     BVT.E1 
          SPACE  2
 M.SEP1   BMASK  (EL.COMMA,EL.LP,EL.SLASH)
          SPACE  3
*         ERROR EXITS FOR BVT AND PSS 
  
 BVT.E1   EREXIT E.DVL1            ILLEGAL ITEM FOLLOWING NAME
          EQ     DATA.N 
  
 BVT.E2   EREXIT E.DVL2            SYNTAX ERROR IN DO NEST
          EQ     DATA.N 
  
 BVT.E3   EREXIT E.DVL3            VAR LIST SYNTAX ERROR
          EQ     DATA.E 
  
 BVT.E4   EREXIT E.DVL4            NO MATCH OF LOOP INDEX 
          EQ     DATA.E 
  
 BVT.E5   EREXIT E.DVL5            A(IVAR) AND NO LOOPS 
          EQ     DATA.N 
  
 BVT.E6   EREXIT E.DVL6            ARRAY SUBSC OUTSIDE OF DIM RANGE 
          EQ     DATA.N 
  
 PSS.E1   EREXIT E.DVL7            VAR( 
          EQ     DATA.N 
  
 PSS.E2   EREXIT E.DVL8            SUB LIST SYNTAX ERROR
          EQ     DATA.N 
  
 BVT.E9   EREXIT E.DVL9            LOCF(A(C1,C2,C3)) OUT OF BOUNDS
          EQ     DATA.N 
* 
 BVT.E10  BX7    X7-X7
          SB6    E.V>C       -VAR LIST LONGER THAN CON LIST-
          SA7    A3          N.ITEM = 0 TO INHIBIT DUPL V>C ERR MSG 
          SB7    BVT         RETURN ADDR
          EQ     ERPROI 
 PSS      EJECT 
*** 
*         PSS - PROCESS SUBSCRIPTS
*                ALLOWED FORM IS C1*IVAR+C2 
* 
*         ON ENTRY: 
*                A4 POINTS TO ( 
* 
*         ON EXIT:  
*                B7 = NUMBER OF VARIABLE SUBSCRIPTS 
*                ELIST POINTER ADVANCED PAST ) AND SAVED IN "SELIST"
*                SUBSCRIPT INFO IN BLOCK STARTING AT "SST"
* 
  
 SAVE     MACRO  X,OP              SAVE AN ELIST WORD IN PROPER ARRAY 
*                                  AND GET NEXT ELIST ITEM
          IFC    NE,//OP/ 
          SX7    B2-OP
          ELSE   1
          BX7    X4 
          SA4    A4-B5             NEXT ITEM
          UX1    B2,X4
          SA7    X+B4 
          ENDM
  
 PSS      ENTRY. *
          SA1    N.DIMS 
          ZR     X1,PSS.E1         IF NAME IS NOT DIMENSIONED 
  
          SB1    X1                B1 = N.DIMS
          SB4    B0                B4 = NUMBER OF SUBSCRIPTS
          SB6    B0                B6 = VARIABLE SUBSCRIPT FLAG 
          MX7    0
          SA7    SST
          SX6    -LSST
  
+         SA7    A7+B5             CLEAR OUT CONTROL CELLS
          SX6    X6+B5
          NG     X6,* 
  
*         SYNTAX CHECK AND SAVE SUBSCRIPT LIST
  
 PSS1     NEXTE                    NEXT ITEM
          IF.NE  CON,PSS2          IF NOT A CONSTANT
          SAVE   CON2 
          IF.NE  EL.STAR,PSS4      IF NO *
          NEXTE 
          SA7    CON1+B4           SAVE AS MULTIPLIER 
          MX6    0
          SA6    CON2+B4           CLEAR ADDEND 
  
 PSS2     IF.NE  NAME,PSS.E2       IF NO VARIABLE 
          SB6    B6+B5             INCREMENT NUMBER OF VARS 
          SAVE   INDX 
          IF.EQ  EL.PLUS,PSS3      IF A + 
          IF.NE  EL.MINUS,PSS4     IF NOT A - 
 PSS3     SAVE   SIGN,EL.PLUS      SAVE ELIST CODE AND GET NEXT ITEM
          IF.NE  CON,PSS.E2        IF NOT A CONSTANT
          SAVE   CON2 
  
 PSS4     SB4    B4+B5             INCREMENT NUMBER OF SUBS 
          EQ     B1,B4,PSS5        IF IT MUST BE A )
          IF.EQ  EL.COMMA,PSS1     LOOP IF A ,
  
 PSS5     IF.NE  EL.),PSS.E2       ERROR IF NO )
          UPDATE                   SAVE ELIST POINTER 
          SX7    B4 
          SX6    B6 
          SA7    N.SUBS 
          SA6    N.VSUB            SAVE NUMBER OF VARIABLE SUBS 
  
*         PROCESS C1"S - CONSTANT MULTIPLIERS 
  
          MX7    0
          SA7    LI                LI = 0 
 PSS6     SA4    CON1+X7           CON1(I)
          SX6    B5 
          ZR     X4,PSS7           IF NO CONSTANT 
          RJ     CHKSC             CHECK AND CONVERT
 PSS7     SA1    LI 
          SA2    N.SUBS 
          SX7    X1+B5
          SA6    CON1+X1           SAVE CONVERTED CON 
          IX5    X7-X2             I - L
          SA7    A1 
          NG     X5,PSS6           IF MORE TO GO
  
*         PROCESS C2"S - CONSTANT ADDENDS 
  
          MX7    0
          SA7    A1                LI = 0 
 PSS8     SA4    CON2+X7           CON2(I)
          MX6    0
          ZR     X4,PSS9           IF NO ADDEND 
          RJ     CHKSC             CONVERT AND CHECK
 PSS9     SA1    LI 
          SA2    N.SUBS 
          ZR     X6,PSS10          IF NO CONSTANT 
          SA3    SIGN+X1           SIGN(I)
          AX4    B5,X3             MAP SIGN ONTO 0 OR -0
          BX6    X4-X6
          SA6    CON2+X1
 PSS10    SX7    X1+B5             I = I+1
          IX5    X7-X2             I - L
          SA7    A1 
          NG     X5,PSS8
  
*         ELIMINATE MULTIPLE APPEARENCES OF AN INDEX VARIABLE 
  
          SA4    N.SUBS 
          SA5    N.VSUB 
          SB6    X4                B6 = N.SUBS
          SB7    X5                B7 = N.VSUB
          LE     B7,B5,PSS         EXIT IF < 2 VARIABLE SUBS
          MX0    60-3 
          SX5    213231B           A(IIJ) , A(JII) , A(IJI) 
  
 PSS11    BX3    -X0*X5            J       ( SMALLER )
          AX5    3
          BX4    -X0*X5            I       ( I > J )
          AX5    3
          SA1    INDX-1+X3
          SA2    INDX-1+X4
          IX6    X1-X2
          SB4    X4 
          NZ     X6,PSS13          IF NO MATCH
  
          SA6    A2                INDX(I) = 0
          NE     B4,B6,PSS12       IF( I = N.SUB ) N.SUB = N.SUB-1
          SB6    B6-B5
 PSS12    SB7    B7-B5             N.VSUB = N.VSUB-1
          SB3    X3 
          SA1    CON1-1+B3
          SA2    CON1-1+B4
          SA3    DIM.MUL-1+B4 
          IX4    X2*X3
          IX6    X1+X4             C1(J) = C1(J)+DIM.MUL(I)*C1(I) 
          SA6    A1 
  
          SA2    CON2-1+B4
          SA1    CON2-1+B3
          SX2    X2-1 
          IX4    X3*X2
          IX6    X4+X1             C2(J) = C2(J)+DIM.MUL(I)*(C2(I)-1) 
          SA6    A1 
          SX7    B5 
          SA7    A2                C2(I) = 1
  
 PSS13    EQ     B7,B5,PSS14       IF ONLY 1 VARIABLE SUB LEFT
          NZ     X5,PSS11          IF MORE COMBINATIONS TO TEST 
  
 PSS14    SX6    B6 
          SX7    B7 
          SA6    A4                UPDATE N.SUB AND N.VSUB
          SA7    A5 
          EQ     PSS
 MDL      TITLE  MDL - MATCH DATA LISTS 
*** 
*         MDL - MATCH DATA LISTS
*                MATCHS A VARIABLE TO DATA ITEM LIST
* 
*         ON ENTRY: 
*                X5 = NUMBER OF EXPLICIT LOOPS
*                "DVT" AND SUBSCRIPT INFO BLOCK SET UP BY "BVT" 
* 
  
*         ADJUST "C.BLOCK" SO THAT WE ARE IN THE RIGHT RELOCATION BASE
  
 MDLX     SA1    DVT
          TBITN  DDD,MDLX1         IF NOT SECOND DEF OF A UDV IN A DATA 
          INTARG
          NARGS= B7 
          FMAC   ORG               OUTPUT ORG MACRO WITHOUT ARGS TO 
          SX6    UDATA.            RESTORE SAVED DATA. ADDRESS
          SA6    C.BLOCK
          EQ     MDL
  
 MDLX1    LX1    59-P.ORGF
          SX5    UDATA.            CLEAR C.BLOCK IF WE ISSUED STORAGE 
          AX1    59                FOR THIS SYMBOL IN DPCLOSE 
          BX6    -X1*X5 
          SA6    C.BLOCK
  
 MDL      ENTRY. *
          SA4    N.ITEM            NUMBER OF ITEMS LEFT IN DATA LIST
          SX6    X4-1 
          PL     X6,MDL1           IF > 0 
          SA6    A4 
          EQ     MDL
  
 MDL1     SA2    DVT+1
          SA1    SDPF              X1 = SDPF
          MX7    0
          SB2    X2                NUMBER OF VARS TO BE INITIALIZED 
          SA7    ORGI              ORGI = 0 
          NZ     X5,MDL4           IF EXPLICIT LOOPS
          GT     B2,B5,MDL2        IF NOT A SINGLE ITEM 
  
*         PROCESS A SINGLE ELEMENT
  
          SA3    BIAS 
          SA6    A4                UPDATE N.ITEM
          RJ     ODV               OUTPUT ORG FOR FWA 
          RJ     GNI               GET NEXT DATA ITEM 
          SA1    DVT+1
          AX1    18 
          SB1    X1                WORD LIMIT 
          RJ     ODI               OUTPUT IT
          SA1    DVT
          BX0    X1 
          LX0    59-P.ORGF
          NG     X0,MDLX           IF NOT FIRST DEF OF USEAGE DEFINED VA
  
          AX1    P.SYMORD 
          SX2    X1              SYMORD 
          AX1    P.SDPF-P.SYMORD
          SB2    X1+B5
          EQ     B1,B2,MDLX        IF DATA ITEM LEN = VARIABLE LEN
  
*         WHEN REAL MATCHED WITH DOUBLE, SEND *  DATA 0B* TO -COMPS-, 
*         TO MAINTAIN THE CORRECT -ORG- COUNTER VALUE.
  
          CALL   PSYM              RETURNS (X3) = VAR NAME
          POSTERR   NR=E.PL,SEV=INF,FMT=DPC,TXT=X3
          SB1    1
          WRITEC =XF.CMPS,DATA.CD,2 
          SB5    1
          EQ     MDLX              MAINTAIN THE ORG COUNTER 
  
*         PROCESS REFERENCE TO WHOLE ARRAY - A # (A(I),I = 1,PI DIMS) 
  
 MDL2     SX6    X1+B5             ADDRESS DIFFERENCE 
          SX7    X2                TRIP COUNT 
          SA5    BIAS 
 MDL3     RJ     OIC               OUTPUT INITIALIZATION CODE 
          EQ     MDLX 
  
*         PROCESS EXPLICIT DO INDEXING
  
 MDL4     SB4    X5                B4 = NUMBER OF LOOPS 
          GT     B4,B5,MDL5        IF MORE THAN 1 LOOP
          SB1    X1                SDPF 
          SA2    LPINF             LOOP INFO WORD 
          AX2    18 
          SX7    X2                TRIP COUNT 
          AX2    18 
          SX3    X2                M
          AX2    18                P
          SA4    DIM.MUL+X2 
          SA5    BIAS 
          LX4    B1,X4
          IX6    X3*X4             ADDRESS DIFF = DM(P)*M(P)*2**SDPF
          SX4    X4 
          IX0    X6-X4             DM(P)*( M(P)-1 )*2**SDPF 
          IX5    X0+X5
          EQ     MDL3 
  
 MDL5     BSS    0
  
*         IRREDUCEABLE NEST OF LOOPS
  
 MDL10    SA2    LPINF
          SA1    SDPF 
          SB1    X1 
          AX2    36 
          SX3    X2                M(P) 
          AX2    18                P
          SA4    DIM.MUL+X2 
          LX4    B1,X4             DM(P)*2**SDPF
          IX7    X3*X4
          SA7    DA                SAVE ADDRESS DIFFERENCE
          UX4    X4 
          SA5    BIAS 
          IX0    X7-X4
          IX7    X0+X5             BIAS = BIAS+DA-DM(P)*2**SDPF 
          SA7    A5 
          SX6    B5 
          SA6    LI+1              LI(2) = 1
          SA6    A6+B5             LI(3) = 1
  
*         CALCULATE BIAS
  
 MDL11    SA4    N.VSUB 
          SA5    BIAS 
          SA3    SDPF 
          SB1    B5                INDEX
          SB2    X4                LIMIT
          SB3    X3                SDPF 
          MX7    0
          SA7    ORGI              ORGI = 0 
  
 MDL12    SA1    LPINF+B1          LPINF(J) 
          AX1    36 
          SX2    X1                M(P) 
          AX1    18                P
          SA3    LI+B1             LI(J)
          SA1    DIM.MUL+X1        DM(P)
          IX4    X2*X3
          SX6    X4-1 
          IX0    X1*X6             DM(P)*(M(P)*LI(J)-1) 
          LX7    B3,X0
          IX5    X5+X7
          SB1    B1+B5
          LT     B1,B2,MDL12
  
          SA1    DA 
          SA2    LPINF
          BX6    X1                ADDRESS DIFFERENCE 
          AX2    18 
          SX7    X2                TC(1)
          RJ     OIC               MATCH UP LISTS 
  
*         INCREMENT INDICES 
  
          SA4    N.VSUB 
          SB1    B5 
          SB2    X4 
  
 MDL13    SA1    LI+B1             LI(J)
          SA2    LPINF+B1 
          SX6    X1+B5             LI(J) = LI(J)+1
          AX2    18 
          SX3    X2                TC(J)
          SA6    A1 
          IX0    X1-X3             I - L
          NG     X0,MDL14          IF LI(J) @ TC(J) 
          SX6    B5                LI(J) = 1
          SA6    A6 
          SB1    B1+B5
          LT     B1,B2,MDL13       LOOP IF J @ N.VSUB 
          EQ     MDLX 
  
 MDL14    SA1    N.ITEM 
          SX2    X1-1 
          PL     X2,MDL11          IF MORE ITEMS TO GO
          EQ     MDLX 
  
  
  
 DATA.CD  LIT    11C  DATA 0B 
 OIC      TITLE  OIC - OUTPUT INITIALIZATION CODE 
*** 
*         OIC - OUTPUT INITIALIZATION CODE FOR A SEQUENCE OF ELEMENTS 
*         OF AN ARRAY WITH A CONSTANT ADDRESS DIFFERENCE BETWEEN THEM.
*         THAT IS, THIS SUBROUTINE OUTPUTS THE INITIALIZATION CODE FOR
*         THE STATEMENT:  
*                ( A(M*I),I = 1,T) / DATA ITEM LIST / 
*         THE ADDRESS DIFFERENCE BETWEEN THE ELEMENTS IS: 
*         A(M*(I+1))-A(M*I) = DM(J)*M*2**SDPF 
* 
*         ON ENTRY: 
*                X5 = ANY ADDITIONAL BIAS 
*                X6 = DA - THE ADDRESS DIFFERENCE 
*                X7 = T - TRIP COUNT
* 
  
 OIC      ENTRY. *
          SA6    DA                SAVE PARAMETERS
          SA7    T
          BX6    X5 
          SA6    B
  
 OIC1     SA3    REPFLAG
          SA5    I.DIT
          SA2    O.DIT
          IX1    X2+X5             NEXT DIT ADDRESS 
          ZR     X3,OIC2           IF NOT IN THE MIDDLE OF A REP
  
*         IN THE MIDDLE OF A REP , ADJUST REP COUNT DECREMENT ( DEC ) 
  
          BX2    X3 
          AX2    36 
          SB4    X2                RL 
          MX7    0                 DEC = 0
          EQ     B4,B5,OIC3        IF RL = 1
          SA4    I.DIT+2           ORDINAL OF START OF DATA IN REP LIST 
          IX5    X4-X5             NEG IF NOT AT THE BEGINNING
          MX0    59 
          AX5    59 
          BX7    X5*X0             DEC = 0 IF AT THE START
          EQ     OIC3 
  
 OIC2     SA3    X1                DIT WORD 
          PL     X3,OIC12          IF NOT THE START OF A REP
          MX7    0                 DEC = 0
  
*         REP LIST ENCOUNTERED - SEE IF WE CAN OUTPUT "REPI" MACROS 
*         A3,X3 - REP LIST INFO WORD - DO NOT DESTROY UNTIL UPDATED 
  
 OIC3     LX4    B5,X3
          AX4    54+1              POSITION CONSTANT ITEM LENGTH FLAG 
          ZR     X4,OIC12          IF ALL ITEMS ARE NOT THE SAME LENGTH 
  
*         N = MIN(RF+DEC,T/RL) = NUMBER OF TIMES WE CAN REP THE DATA
  
          SA5    T
          SB4    X4                B4 = CIL FLAG
          SX0    X3                X0 = RF
          BX2    X3 
          AX2    36 
          SX6    X2                RL 
          SB2    X2                B2 = RL
          SA6    RL 
          IX0    X0+X7             RF+DEC 
          IX5    X5/X6             T/RL 
          MX6    X5-X0       MIN OF THE TWO 
          SB6    X6 
          LE     B6,B5,OIC12       IF WE CAN"T REP IT AT LEAST 2 TIMES
          SA5    SDPF 
          SB3    X5+B5             WORDS/ELEMENT
          GT     B4,B3,OIC12       IF DATA ITEMS LONGER THAN VAR ELEMENT
  
          SA6    N                 SAVE REP COUNT 
          SX5    X6-1              DECREMENT REP LIST COUNT BY N-1 FOR
          IX6    X3-X5             GNI SINCE WE WILL CALL IT ONLY ONCE
          SA6    A3                TO OUTPUT THE DATA ITEMS N TIMES 
  
          SA1    DA 
          SX2    B2                RL 
          SB6    B4-B5             CIL FLAG - 1 
          LX7    B6,X2             RL*CIF 
          IX5    X7-X1
          IX6    X1*X2
          SA6    MP                MP = DA*RL 
          NE     B3,B4,OIC7        IF 1 WORD ITEMS AND 2 WD/ELE VARS
          EQ     B2,B5,OIC5        IF RL = 1
          SB7    X1                DA 
          NE     B7,B4,OIC7        IF DA " CIL
  
*         RL = 1 OR DA = CIL - OUTPUT THE DATA AND A SINGLE REPI
  
 OIC5     SA7    DLEN              SAVE LENGTH OF DATA LIST ( *CIL )
          SA3    B
          RJ     ODV               OUTPUT ORG TO SET DATA PLACEMENT ADDR
          SA1    RL 
          BX6    -X1
  
 OIC6     SA6    LI 
          RJ     GNI               GET NEXT ITEM
          SA1    SDPF 
          SB1    X1+B5             WORD LIMIT 
          RJ     ODI               OUTPUT DATA ITEM 
          SA1    LI 
          SX6    X1+B5             DECREMENT INDEX
          NZ     X6,OIC6
  
          SA1    N                 REP COUNT
          SA2    MP                FWA INCR 
          SA4    DLEN              NUMBER OF DATA WORDS 
          LX3    X2                DESTIN OFFSET
          BX6    X4 
          RJ     ORP               OUTPUT REPI MACRO CALL 
          EQ     OIC9 
  
*         RL > 1 AND DA " CIL - PUT OUT A REP FOR EACH DATA ITEM
  
 OIC7     SA3    B
          SX7    -B2
          BX6    X3 
          SA7    TMP
          SA6    A7+B5             AND COPY OF BIAS 
  
 OIC8     RJ     ODV               OUTPUT ORG TO SET DATA PLACEMENT ADDR
          RJ     GNI               GET DATA LIST POINTER
          SA1    SDPF 
          SB1    X1+B5             SET WORD LIMIT 
          RJ     ODI               OUTPUT DATA STMT 
          SA1    N                 REP COUNT + 1
          SA2    MP                I
          BX3    X2                D
          SX6    B1                B
          RJ     ORP               OUTPUT REPI MACRO
          SA1    TMP               LOOP INDEX 
          SA2    DA 
          SA3    A1+B5             BIAS 
          IX6    X2+X3             B = B+DA ( ADVANCE BIAS )
          SA6    A3 
          BX3    X6 
          SX7    X1+B5             DECREMENT LOOP INDEX 
          SA7    A1 
          NG     X7,OIC8
  
*         END OF REP OUTPUT - UPDATE COUNTERS ( N.ITEM,T AND B )
  
 OIC9     SA1    N
          SA2    RL 
          SA3    B
          SA4    N.ITEM 
          IX0    X1*X2             N*RL = NUMBER OF ELEMENTS PROCESSED
          SA2    DA 
          SA5    T
          MX7    0
          SA7    ORGI              ORGI = 0 
          IX1    X0*X2
          IX7    X3+X1             B = B+DA*(N*RL)
          SA7    A3 
          UX0    X0 
          IX6    X4-X0             DECREMENT NUMBER OF ITEMS LEFT 
          SA6    A4 
          IX7    X5-X0             AND NUMBER OF VARS LEFT
          SA7    A5 
          ZR     X6,OIC10          IF DATA LIST IS EXHAUSTED
          NZ     X7,OIC1           IF MORE VARIABLES TO GO
  
 OIC10    IX6    X6-X7             N.ITEM = N.ITEM-T
          SA6    A6                FORCE AN INFORMATIVE ERROR IF T " 0
          EQ     OIC
  
*         NOT AT THE START OF A REP OR CANNOT REP WITH THIS ITEM LIST 
*         OUTPUT ITEMS UNTIL WE HIT THE START OF THE NEXT REP OR
*         T = 0 OR N.ITEM = 0 
  
 OIC12    SA2    DVT+1
          AX2    18 
          SX7    X2                SAVE WORD LIMIT
          SA7    TMP
  
 OIC14    SA1    DA 
          SA2    ORGI 
          IX0    X1-X2
          ZR     X0,OIC15          IF WE DON"T NEED AN ORG
          SA3    B
          RJ     ODV               SET DATA PLACEMENT ADDRESS 
 OIC15    RJ     GNI               GET NEXT DATA ITEM 
          SA1    TMP
          SA2    B
          SA4    DA 
          IX3    X1-X2
          SB1    X3                WORD LIMIT FOR THIS ELEMENT
          IX7    X4+X2             B = B+DA ( ADVANCE BIAS  ) 
          SA7    A2 
          RJ     ODI               OUTPUT A DATA ITEM 
          SX6    B1 
          SA6    ORGI              SAVE ORG COUNTER INCREMENT 
  
          MX0    59 
          SA4    N.ITEM 
          SA5    T
          IX6    X4+X0             DECREMENT NUMBER OF ITEMS LEFT 
          SA6    A4 
          IX7    X5+X0             AND NUMBER OF VARIABLES LEFT 
          SA7    A5 
          ZR     X6,OIC10          IF NO MORE DATA ITEMS LEFT 
          ZR     X7,OIC            IF FINISHED WITH THE VARS
  
          SA1    I.DIT
          SA2    O.DIT
          IX1    X1+X2              BASE ADDRESS + ORDINAL
          SA3    X1                NEXT DIT WORD
          MX7    0
          PL     X3,OIC14          IF NOT THE START OF A REP
          EQ     OIC3 
 ODV      TITLE   OUTPUT ROUTINES 
*** 
*         ODV - OUTPUT DATA VARIABLE ADDRESS
*         OUTPUTS AN "ORG" MACRO CALL TO SET THE FWA FOR DATA PLACEMENT 
* 
*         ON ENTRY: 
*                X3 = ANY ADDITIONAL BIAS DUE TO SUBSCRIPT CALCULATIONS,
* 
  
 ODV      ENTRY. *
          SA1    DVT
  
 #DAL     IFNE   .DAL,0      .NZ. IF LCM DIRECT ACCESS ALLOWED
          BX2    X1 
          LX2    59-P.LCMI
          PL     X2,ODV.1    IF NOT LCM INDIRECT ADDRESS MODE 
          SX6    B5 
          SA6    =XIAF       FOR FMAC 
 ODV.1    BSS    0
 #DAL     ENDIF 
  
          INTARG                   INITIALIZE FOR FMAC CALL 
          SX2    X1                SAVE BIAS DUE TO EQUIVALENCING 
          AX1    18 
          SX6    X1 
          SVARG  NAME,B5           ARG1 = VARIABLE NAME 
          IX6    X2+X3
          ZR     X6,ODV1           IF NO BIAS 
          SVARG  OCT,B5+B5         ARG2 = BIAS
  
 ODV1     LX1    59-P.DDD+18
          PL     X1,ODV2           IF NOT SECOND APPEARENCE OF UDV IN 
          SX6    B5                DATA STMT
          SVARG  INT,3             ARG3 = FLAG
 ODV2     NARGS= B7                SAVE ARGS
          FMAC   ORG               FORM MACRO CALL
          EQ     ODV
 ORP      SPACE  3
*** 
*         ORP - OUTPUT "REPI" MACRO CALL
* 
*         ON ENTRY: 
*                X6 = DATA BLOCK LENGTH ( NUMBER OF WORDS TO BE REPPED )
*                X1 = REP COUNT + 1 
*                X2 = FWA INCREMENT BETWEEN REPS
*                X3 = DESTINATION ADDRESS OFFSET
* 
  
 ORP      ENTRY. *
          INTARG                   INITIALIZE FOR FMAC CALL 
          IX0    X6-X2
          IX4    X3-X6
          SVARG  OCT,B5            ARG1 = DLEN
          SX6    X1-1 
          SVARG  OCT,B5+B5         ARG2 = REPLICATION COUNT 
          ZR     X0,ORP1           IF THIRD ARG IS NOT NECESSARY
          BX6    X2 
          SVARG  OCT,B7+B5         ARG3 = FWA INCREMENT 
 ORP1     ZR     X4,ORP2           IF FOURTH ARG NOT NECESSARY
          BX6    X3 
          SVARG  OCT,4             ARG4 = DESTIN ADDRESS - LOCF(S.) 
  
 ORP2     NARGS= B7                SAVE ARGUMENT COUNT
          FMAC   REPI              OUTPUT REPI MACRO CALL 
          EQ     ORP
 ODI      EJECT 
*** 
*         ODI - OUTPUT DATA ITEM
* 
*         ON ENTRY: 
*                B1 = MAX NUMBER OF DATA WORDS THAT MAY BE ISSUED 
*                A5,X5 = FWA OF DIT ENTRY 
* 
*         ON EXIT:  
*                B1 = NUMBER OF DATA WORDS THAT WE ISSUED 
*                     ( ORG COUNTER INCREMENT ) 
* 
  
 ODI      ENTRY. *
          BX6    X5                STORE THIS CONSTANTS*S ELIST ENTRY 
          AX6    40 
          SA2    X6 
          BX7    X2 
          SA6    EL.HOL 
          SA7    EL.CNS 
          MX6    0
          SB2    X5                NUMBER OF WORDS IN DATA ITEM 
          SA6    TC.HOL            CLEAR TRUNCATE FLAG
          LX0    B5,X5
          SA6    LI.HOL            CLEAR LAST ISSUE FLAG
          SX6    B1-B2             < 0 IF WC(D) > WORD LIMIT
          SX7    A5+B5
          LX7    18 
          SX4    B2 
          SA6    TEMP 
          BX7    X4+X7             SAVE DATA WORD ADDR AND WC(D)
          SA7    A6+B5
          NG     X0,ODI1           IF A HOLLERITH CONSTANT
  
*         PROCESS 1 OR 2 WORD CONSTANT
  
          SA1    DVT         CHECK CONSTANT TYPE
          MX0    4
          BX6    X1-X5
          LX0    P.CTYP+L.TYP      POSITION MASK
          BX6    X0*X6
          ZR     X6,ODI0     IF NO TYPE CONFLICT
  
          POSTER NR=E.DTC,SEV=ANSI,FMT=ELIST,TXT=SNAME
  
 ODI0     SA5    A5+B5       FIRST WORD OF CON
          RJ     IDW               ISSUE TO COMPS FILE
          SA2    TEMP+1 
          SA1    A2-B5
          SB1    X2 
          SA1   DVT 
          LX1   2 
          PL    X1,ODI00    IF NOT DIM COMPLEX VAR WITH DELAY STORE 
          SA1   SDPF
          ZR    X1,ODI00    IF NOT COMPLEX VAR
          SA1   N.SUBS
          ZR    X1,ODI00    IF NOT DIM VAR
          NE     B1,B5,ODI00 IF OUTPUT MORE THAN ONE WORD 
          SB1   B1+B1 
          SX5   0 
          RJ    IDW         OUTPUT SECOND DATA WORD 
          SA2   TEMP+1
          SA1   A2-B5 
          SX7   0 
          SA7   SDPF
          SA7   N.SUBS
          EQ    ODI 
 ODI00    SA2   TEMP+1
          SA1   A2-B5 
          EQ    B1,B5,ODI 
          MI     X1,ODI4           IF 2 WORDS OF DATA FOR 1 WORD ITEM 
  
          AX2    18 
          SA5    X2+B5
          RJ     IDW               OUTPUT SECOND DATA WORD
          SB1    B5+B5
          EQ     ODI
  
*         OUTPUT HOLLERITH CONSTANT 
  
 ODI1     SA1    SDPF 
          SB3    X1+B5
          LE     B2,B3,ODI2        IF HOL CONST < ELEMENT LENGTH
          SA7    NONANSI           SET NON ANSI USEAGE FLAG 
  
 ODI2     AX5    36                CHARS IN LAST WORD 
          BX6    X5 
          AX6    4
          SX6    X6 
          SA6    TEMP+2 
          LE     B2,B1,ODI3        IF CON LEN @ WORD LIMIT
          SX7    B1                ORGC INC = WORD LIMIT
          SA7    A6-B5
          MX5    0                 NO CHARS IN LAST WORD
          SB2    B1 
  
 ODI3     SA4    A5+B5             ELIST FOR THE CON
          MX7    -4 
          BX5    -X7*X5 
          CALL   OHC               OUTPUT IT
          SA4    TEMP+2 
          MX6    1
          SA3    X4-1              LOOK AHEAD 
          SA6    LI.HOL            SET LAST ISSUE FLAG
          UX7    B3,X3
          SA4    X4 
          SA2    TEMP+1 
          AX4    18 
          SA1    A2-B5
          SB4    X4-11
          SB1    X2                ORG COUNT INCREMENT
          SB3    B3-EL.COMMA
          BX7    X1 
          MX1    0
          MI     B4,ODI            IF .LE. 10 HOLL. CHARACTERS
          ZR     B3,ODI4           IF OTHER CONSTANTS 
          PL     X7,ODI            IF CON. LENGTH .LE. WORD LIMIT 
  
*         ISSUE INF. DIAGNOSTIC - CON. LEN. .GT. ITEM LEN., TRUNCATED.
  
 ODI4     SB1    B1+X1             ORG COUNT INC.=WC(D)+(LIM-WC(D))=LIM 
          MX7    1
          SA7    TC.HOL            SET TRUNCATE FLAG
          POSTER NR=E.TRC,SEV=INF,FMT=ELIST,TXT=EL.CNS,RETURN=ODI 
 IDW      SPACE  3
***       IDW - ISSUE A DATA WORD TO THE COMPS FILE 
* 
*         ON ENTRY: 
*                X5 = DATA WORD 
* 
  
 IDW1     INTARG                   INITIALIZE FOR FMAC CALL 
          SVARG  OCT,B5 
          NARGS= B7 
          FMAC   DATA              OUTPUT DATA WORD 
  
 IDW      ENTRY. *
          MX0    43 
          BX1    X0*X5
          AX1    17 
          BX6    X5 
          ZR     X1,IDW1           IF A SMALL CONSTANT
          BX1    X5 
          CALL   BTOCT             CONVERT ALL 20 DIGITS TO OCTAL 
          SA6    IDW.D+1
          SA7    A6+B5
          SB1    1
          WRITEC =XF.CMPS,IDW.D,4  DATA LINE TO -COMPS- 
          SB5    1
          EQ     IDW         EXIT 
  
  
  
 IDW.D    DATA   31C  DATA    12345678901234567890B 
 GNI      EJECT 
**        GNI  -  GET ADDRESS OF NEXT DATA ITEM.
* 
*         EXIT   A5,X5 = ADDRESS AND CONTENTS OF FIRST WORD OF NEXT 
*                        DATA ITEM FROM *DIT*.
  
 GNI      ENTRY. *
          SA1    I.DIT
          SA2    O.DIT
          IX6    X1+X2
          SA5    X6                NEXT WORD FROM DIT 
          SA2    A1+B5             REP COUNT REMAINDER
          PL     X5,GNI1           IF NOT THE START OF A REP LIST 
  
*         INITIALIZE REP LIST PROCESSING
  
          BX6    X5 
          SX7    X1+B5
          SA6    REPFLAG
          SA7    A2+B5             SAVE ORDINAL OF REP LIST START 
          AX6    36 
          BX7    -X6
          SA7    A2                SET REMAINDER = -N.ITEMS IN REP LIST 
          BX2    X7 
          SA5    A5+B5             GET FIRST DATA WORD
          SX1    X1+B5             ADVANCE INDEX PAST REP WORD
  
*         ADVANCE I.DIT TO POINT TO NEXT ITEM AND SEE IF WE ARE IN A
*         REP LIST
  
 GNI1     BX0    X5 
          AX0    18 
          IX7    X0+X1             UPDATE INDEX 
          SA7    A1 
          ZR     X2,GNI            IF NO REPETITION 
          SX7    X2+B5
          SA7    A2                UPDATE REMAINDER 
          NZ     X7,GNI            EXIT IF MORE TO GO 
  
*         DECREMENT REP COUNT AND START BACK AT START OF REP LIST IF RC 
  
          SA3    REPFLAG
          SX0    B5 
          IX7    X3-X0             DECREMENT REP COUNT
          SA7    A3 
          SB7    X7 
          ZR     B7,GNI2           IF FINISHED
          AX3    36 
          BX7    -X3               RESET REMAINDER
          SA7    A2 
          SA4    A2+B5             ADDRESS OF FIRST DATA ITEM IN REP LIS
          BX7    X4 
          SA7    A1                RESET I.DIT FOR NEXT ENTRY 
          EQ     GNI
  
 GNI2     MX7    0
          SA7    A7                REPFLAG = 0
          EQ     GNI
          TITLE              PDV- PROCESS DATA VARIABLE 
 PDV.E1   EREXIT E.DVN1            NAME IS F.P. FUN , EXT OR IN // COM
          EQ     DATA.N 
  
 PDV.E2   EREXIT E.DVN2            AN ILLEGAL TYPE ( ECS VAR , ETC )
          EQ     DATA.N 
  
*** 
*         PDV - PROCESS DATA VARIABLE 
*         PROCESS"S VARIABLE NAME MENTIONED IN A DATA STMT
* 
*         ON ENTRY: 
*                X1 = 8R_NAME 
* 
*         ON EXIT:  
*                SEMANTICS CHECK FOR LEGAL NAME PERFORMED 
*                ENTRY MADE IN DATA TBL IF FIRST APPEARENCE OF NAME 
*                IN SUBPROGRAM
*                REGISTERS RESTORED BY A CALL TO MACRO "GETE" 
* 
  
*         FIRST OCCURANCE OF THE NAME - SET TYPE
  
 PDV.F    ZR     X7,PDV.F1         IF NO PREVIOUS OCCURANCES IN DEBUG ST
          CFO    VAR               CHECK SETTING OF DEBUG BITS
 PDV.F1   IX2    X6+X2             SET TYPE 
          EQ     PDV1 
  
 PDV      ENTRY. *
          UPDATE                   SAVE ELIST POINTER 
          BX7    X4 
          SA7    SNAME             SAVE NAME IN CASE OF ERRORS
          SYMBOL                   GET SYMTAB ORDINAL 
          EQ     PDV.F             FIST OCCURANCE 
  
*         PREVIOUS OCCURANCES - CHECK FOR A LEGAL VARIABLE
  
          EQ     B1,B5,PDV.E2      IF THE SUBPROGRAM NAME 
          BX4    X2 
          LX4    59-P.EXT 
          BX3    X1 
          LX3    59-P.FP
          BX4    X3+X4
          LX3    P.FP-P.FUN 
          BX4    X3+X4
          NG     X4,PDV.E1         IF FP , FUN OR EXT 
  
 PDV1     MX0    L.TYP
          SX7    B1 
          BX4    X2 
          SA7    ORD
          LX4    59-P.LCM 
          LX7    P.SYMORD 
          PL     X4,PDV1.A   IF NOT LCM 
          SA5    =XDIRECT 
          ZR     X5,PDV1.A   IF NOT INDIRECT MODE 
          SX5    B5 
          LX5    P.LCMI 
          BX7    X7+X5
 PDV1.A   BSS    0
          BX4    X0*X2
          LX4    L.TYP             POSITION TYPE FIELD
          SX5    X4-T.OCT 
          BX6    X4 
          LX6    P.CTYP      POSITION CONSTANT TYPE 
          BX7    X7+X6
          PL     X5,PDV.E2         IF AN ILLEGAL TYPE 
  
          SB2    B0                B2 " 0 IF VARIABLE IS IN COMMON
          SX5    X4-T.DBL 
          SX0    B5 
          AX5    L.TYP
          BX6    -X5*X0            0 IF SINGLE , 1 IF 2 WORDS/ELEMENT 
          SA6    SDPF 
          SB7    X6                B7 = SDPF
          LX6    P.SDPF 
          BX7    X6+X7
  
*         CHECK FOR VARIABLE IN BLANK COMMON OR SECOND DEF IN DATA STMT 
  
          MX6    0
          SA6    INFDIAG
          BX3    X1 
          LX3    59-P.COM 
          NG     X3,PDV1A    IF VAR IS IN COMMON
          SA4    PROGRAM
          NZ     X4,PDV3     IF NOT IN BLOCK DATA 
          MX6    1
          SA6    INFDIAG
 PDV1A    BX4    X2 
          MX0    60-L.RB
          AX4    P.RB 
          BX5    -X0*X4 
          NZ     X5,PDV2           IF REALLY IN COMMON
          SX6    B5 
          LX6    P.DDD
          BX7    X6+X7             FLAG VAR DOUBLY DEFINED IN DATA STMT 
          EQ     PDV3 
  
 PDV2     SA3    ORGTAB-1+X5       BLOCK NAME 
          MX0    60-17
          BX4    -X0*X3 
          SB2    X4 
          AX3    54 
          SX4    X3+77B-1R
          ZR     X4,PDV.E1         IF IN BLANK COMMON 
          SA3    PROGRAM
          BX6    X3 
          ZR     X3,PDV3
          SA6    NONANSI     NON ANSI IF NOT IN BLOCK DATA
  
*         SET ORGF BIT IN DVT IF "DPCLOSE" ISSUED STORAGE FOR THIS VAR
  
 PDV3     BX3    X2 
          MX0    60-L.DIMP
          AX3    P.DIMP 
          BX4    -X0*X3 
          SX3    V.SCA
          LX5    X4,B5
          BX0    X3*X2       SCA BIT
          LX0    59-P.SCA 
          AX0    59          EXTEND SCA BIT 
          BX5    -X0*X5      ZERO X5 IF DIMP POINTS TO SCA TABLE
          SB6    X5          B6 = INDEX TO DIM TABLE
          SX0    V.COM
          BX3    X0*X1             COMMON BIT 
          IX4    X3+X5             X4 " 0 IF WE ISSUED STORAGE FOR THIS 
          NZ     X4,PDV4           VARIABLE IN DPCLOSE
          BX1    X0+X1             SET COMMON BIT 
          SX0    B0                CLEAR ORG FLAG 
  
 PDV4     LX0    P.ORGF-P.COM 
          BX7    X0+X7             SAVE ORG/NO ORG FLAG 
          SA7    DVT               SAVE WORD 1 OF DVT ENTRY 
  
*         SET DEFINED AND VAR BITS IN SYMTAB ENTRY
  
          SX0    V.DEF
          BX6    X0+X1             SET DEFINED BIT
          SA6    A1 
          LX0    P.VAR-P.DEF
          BX6    X0+X2             SET VAR BIT
          SA6    A2                UPDATE SYMTAB ENTRY
  
          SB4    B5+B7             B4 = WORD COUNT ( STORAGE ASSIGNED ) 
          MX6    0
          SA6    EEL
          SA6    A6+B5             N.DIMS = 0 
          ZR     B6,PDV6           IF NO DIM ENTRY
          SA3    DIM1 
          SB6    X3+B6             ADDRESS OF IT
  
*         SAVE DIMENSION INFO 
  
          TBITN  DIM,PDV5          IF NO DIMENSIONS 
          SA3    B6+B5             WORD 2 OF DIM ENTRY
          MX0    3
          BX6    X0*X3
          LX6    3
          SA6    N.DIMS            SAVE NUMBER OF DIMENSIONS
          SX0    X6-3 
          SX6    X3 
          SA6    DIM.MUL+1
          SA6    DIM
          AX3    18 
          SX7    X3                DIM2 
          SA7    A6+B5
          AX3    18 
          SB4    X3                WORDS OF STORAGE 
          SX3    X3 
          AX4    B7,X3             NUMBER OF ITEMS
          NG     X0,PDV5           IF < 3 DIMS
          IX6    X6*X7             DIM1*DIM2
          SA6    D1D2 
          IX7    X4/X6             (PI DIMS)/(DIM1*DIM2)
          SA7    A7+B5             STORE DIM3 
  
*         EQUIVALENCED - SUBSTITUTE ORD OF BASE AND A BIAS
  
 PDV5     TBITN  EQU,PDV6          IF NOT EQUIVALENCED
          SA3    B6                WORD 1 OF DIM ENTRY
          SA5    DVT
          AX3    18 
          MX0    60-36
          BX7    X0*X5             REMOVE SYMORD FROM DVT ENTRY 
          BX3    -X0*X3            SAVE BASE AND BIAS 
          BX7    X3+X7
          SA7    A5 
  
 PDV6     SA2    PL 
          ZR     X2,PDV7           IF NOT IN A DO NEST
          TBITN  DIM,PDV7          IF NOT DIMENSIONED 
  
*         IF NAME IS IN AN EQUIVALENCE CLASS, THEN
*                EEL = CLASS LENGTH - ARRAY BIAS
  
          BX0    X1 
          LX0    59-P.EQU 
          NG     X0,PDV6A          IF A NON BASE MEMBER 
          SA3    B6                WORD 1 OF DIM ENTRY
          PL     X3,PDV7           IF NOT THE BASE MEMBER OF THE CLASS
          SB3    B0                BIAS = 0 
          AX3    36                CLASS LEN OR 0 IF IN COMMON
          SB2    B2+X3
          EQ     PDV6B
  
 PDV6A    SB3    X3                BIAS 
          NZ     B2,PDV6B          IF IN COMMON 
          AX3    18-1 
          SB2    X3+B5             2*ORD(BASE)+1
          SA2    A0-B2             WORD B OF BASE 
          MX0    60-L.DIMP
          AX2    P.DIMP 
          BX1    -X0*X2 
          SA4    DIM1 
          LX3    B5,X1             DIMP INDEX 
          IX5    X3+X4
          SA1    X5                WORD 1 OF DIM ENTRY OF CLASS BASE
          AX1    18 
          SB2    X1                CLASS LENGTH 
 PDV6B    SX6    B2-B3             CLASS LEN - ARRAY BIAS 
          SA6    EEL               SAVE EXTENDED ARRAY LENGTH 
  
 PDV7     SA1    DVT
          BX0    X1 
          AX0    P.SDPF 
          SB7    X0 
          SX6    B4                NUMBER OF WORDS
          AX5    B7,X6             NUMBER OF ITEMS
          LX6    18 
          BX6    X5+X6
          SA6    A1+B5             SAVE SECOND WORD OF DVT
          LX1    59-P.ORGF
          NG     X1,PDV8           IF NO DATA TABLE ENTRY NECESSARY 
  
*         FIRST OCCURANCE OR USEAGE DEFINED VAR - SAVE ADDR AND SYMORD
*         IN DATA TABLE SO "ENDPRO" CAN DEFINE ITS ADDRESS
  
          SA2    DATA.
          SX7    X2+B4             INCREMENT DATA. LENGTH 
          SA7    A2 
          SX6    B1 
          LX6    18 
          BX1    X6+X2             24/0,18/SYMORD,18/RA 
          ADDWD  DATA,X1           SAVE ORDINAL AND ADDR IN DATA TABLE
          SA1    ORD
          SB1    X1                RESTORE B1 
  
 PDV8     SA5    RSELECT
          ZR     X5,PDV9           IF NO LONG MAP 
          ADDREF B1,DEF            A DEFINITION FOR THE NAME
  
 PDV9     SA1    INFDIAG
          ZR     X1,PDV10 
          POSTER NR=E.DNC,SEV=INF,TXT=SNAME,FMT=ELIST 
 PDV10    GETE               RESTORE REGISTERS
          EQ     PDV
  
          END 
