         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 4.1 - DATA REF SUBROUTINES'
* REGISTER EQUIVALENCES
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6                                                     117
R7       EQU      7                                                     116
V0       EQU      8
V1       EQU      9
V2       EQU      10
L0       EQU      V2                                                    1212
L1       EQU      11                LINK REGISTER
D0       EQU      12                DECA
D1       EQU      13
D2       EQU      14
D3       EQU      15
*CONDITION CODE EQUIVALENCES
CM       EQU      1                 NEGATIVE
CP       EQU      2                 POSITIVE
CZ       EQU      3                 ZERO(RESET)
CL       EQU      CM                LESS                                ADI
CG       EQU      CP                GREATER                             ADI
CE       EQU      CZ                EQUAL(RESET)
CV       EQU      4                 OVERFLOW
CC       EQU      8                 CARRY OVER
CA       EQU      CP                AND BIT
CB       EQU      CV                BIT COMPARE
*
         DEF      ADI00,ADI02       REF
         DEF      ADJ06,ADJ22       SUBSCRIPT ERROR, INVS SWITCHES
         REF      RDCRF
         REF      DIAG
         REF      AAC00             READ
         REF      AAZ00             COMPILER ERROR
         REF      PDBZ              DDB ADCONS
*                                             +3 = WA(DBB BASE)
*                                             +4 = NO. OF DDB'S,
*                                                  WA(DBINDX)
         REF      JMCRD,JMCER,JRDF  RETURNS,READ
         REF      JMCSX,JMCSI       SUBSCRIPT ERROR, INVS SWITCH
         REF      AEC40,AEC50
         REF      STBAS             DATA STACK
         REF      RDECP
         REF      JAKON,JADAT,JASAV
         REF      PDBDBG                                                COBOL41P
         REF      DBSIZE                                                COBOL41P
         REF      PDBP
         REF      JFDEC
         DEF      ADV00,ADS00,ADW00
         DEF      ADL00,AVI00,CORRF
         DEF      ECFRF,ADVMF
* READ PROC                                                             APR
* LF     R---     R-,+/-HW OFFSET,INDIRECT ADDR.                        APR  1
RCEF     CNAME    0                                                     APR00
RECF     CNAME    1                                                     APR01
RCRF     CNAME    2                                                     APR02
         PROC                                                           APR04
         DO       NAME>1                                                APR10
LF       BAL,L1   AAC00             READ CRF CLUSTER                    APR11
         ELSE                                                           APR12
         DO       NAME                                                  APR13
LF       BAL,L1   AAE00             READ ECF CLUSTER                    APR14
         ELSE                                                           APR15
LF       BAL,L1   *AF(3)            READ CRF/ECF CLUSTER                APR16
         FIN                                                            APR17
         FIN                                                            APR18
         DO       NUM(AF(1))                                            APR30
         LW,AF(1) R2                LOAD HA(CLOC)+/- HW OFFSET          APR31
         DO       NUM(AF(2))                                            APR40
         AI,AF(1) AF(2)                                                 APR41
         ELSE                                                           APR42
         AI,AF(1) 1                                                     APR43
         FIN                                                            APR44
         FIN                                                            APR44
         PEND                                                           APR50
* DIAG PROC                                                             APD
DX       CNAME                                                          APD00
         PROC                                                           APD01
* AF     DX       DIAG CODE,LINK                                        APD02
LF       LI,R1    AF(1)             LOAD DIAG CODE                      APD10
         DO       NUM(AF(3))
         B        DIAG              WRITE DMF CLUSTER
         ELSE
         DO       NUM(AF(2))
         LI,L1    AF(2)             LOAD LINK REGISTER
         B        DIAG              WRITE DMF CLUSTER                   APD242
         ELSE                                                           APD243
         BAL,L1   DIAG              WRITE DMF CLUSTER                   APD244
         FIN                                                            APD248
         FIN                                                            APD29
         PEND                                                           APD40
* LINK(OR LOAD) AND BRANCH PROC                                         APL
* LF     LAB,L/R  BRANCH ADDRESS,LINK ADDRESS(OR LOAD VALUE)            APL  1
LAB      CNAME                                                          APL01
         PROC                                                           APL04
LF       LI,CF(2) AF(2)             SET LINK REGISTER                   APL12
         B        AF(1)             BRANCH                              APL14
         PEND                                                           APL90
* DIAG CODE BASE EQUIVALENCES
XDA      EQU      90                A DIAG CODE BASE - DATA
XDS      EQU      93                S DIAG CODE BASE - DATA
XDW      EQU      138               W DIAG CODE BASE - DATA
XSS      EQU      164               S DIAG CODE BASE - SUBSCRIPT/INDEX
XSW      EQU      178               W DIAG CODE BASE - SUBSCRIPT/INDEX
XTW      EQU      210               W TRUNCATION
*                                                                       AA0
CBYT     EQU      X'FF'             BYTE MASK
CHBYT    EQU      X'F'              HALF-BYTE MASK
CFFF     EQU      X'FFF'          A SELECTIVE MASK                      ADJ
*
CACBL    EQU      16                BA(LNG OF FIXED PORTION) +1         ADI
CACHL    EQU      8                 HA(LNG OF FIXED PORTION) +1         ADI398
CBALL    EQU      X'100'          A AN LIT ALL INDICATOR                ADI903
CBFCT    EQU      X'F00'          A FIGCON TYPE                         ADI801
CBND     EQU      X'700'          A DATA NAME(NOT COND/FILE/PROC)       ADI201
CBSDN    EQU      X'F9200'        A SUBSCRIPT DATA NAME
CBSLT    EQU      X'FD100'        A LITERAL SUBSCRIPT                   ADJ144
CBSUB    EQU      X'60'             NSUB MASK                           ADI445
CBXDC    EQU      X'FD300'        A INDEX DECREMENT                     ADJ147
CBXDM    EQU      X'100'          A INDEX DECREMENT ADJ                 ADI
CBXIM    EQU      X'2E00'         A INDEX INCREMENT ADJ                 ADI
* DATA CLUSTER TYPE,CLASS EQUIVALENCES
CDANE    EQU      X'300'          A ALPHANUMERIC EDITED                 ADI361
CDCL     EQU      X'F00'          A CLASS MASK                          ADJ473
CDDNI    EQU      X'400'          A ND/NC NON-INTEGER ADJ.              ADJ441
CDFPS    EQU      X'E00'          A FLOATING POINT SINGLE CLASS         ADI725
CDFXL    EQU      X'600'          A FIXED LNG ITEM                      ADI603
CDIM     EQU      7                 NDIM MASK
CDIXD    EQU      X'C00'          A INDEX DATA CLASS                    ADI707
CDIXN    EQU      X'FCC00'        A INDEX NAME                          ADI241
CDNC     EQU      X'800'          A NUMERIC COMPUTATIONAL               ADI341
CDNDC    EQU      X'600'          A NUMERIC DISPLAY/COMPUTATIONAL       ADJ343
CDNE     EQU      X'500'          A NUMERIC EDITED                      ADI343
CDNIX    EQU      X'300'          A NOT INDEX                           ADJ555
CDRN     EQU      X'4000'           RECORD NAME(NOT MNEM.)              ADI228
CDSFL    EQU      X'E'            A FLP INDEX CODE                      ADJ596
CDZF     EQU      X'10'           A ND ZERO FILL INDICATOR              ADI615
CELNG    EQU      5               M NE EDIT INFO LNG                    ADI516
*
CGBSZ    EQU      10              A DIGIT SIZE - BIN                    ADI762
CGFLS    EQU      30
CGFSS    EQU      30                DIGIT SIZE - FLS
CGMXB    EQU      16              A MAX. DECIMAL BYTE SIZE              ADJ382
CGMXC    EQU      18              A MAX. NO. OF DIGITS(COMP)            ADI575
CGMXD    EQU      31                MAX. NO. OF DIGITS (DISPLAY)
CGMXS    EQU      6               A MAX. DIGIT SIZE(SUBSCRIPTS)         ADJ451
* REF CNTL EQUIVALENCES
CIADO    EQU      X'300'          A AN/DISPLAY ONLY                     ADI601
CIAND    EQU      X'C00'          A AN/ANE ALLOWED                      ADI346
CIANX    EQU      X'400'          A AN USAGE ERROR - ALLOWED            ADI406
CIAN     EQU      X'800'          A AN USAGE                            ADI403
CIANO    EQU      X'200'          A AN ONLY                             ADI561
CIGPO    EQU      X'2000'         A GROUP ONLY                          ADI301
CIGP     EQU      X'8000'         A GROUP ALLOWED                       ADI324
CIGPX    EQU      X'4000'         A GROUP USAGE ERROR - ALLOWED         ADI326
CILC     EQU      CINCO           A LITERAL COMPUTATIONAL USAGE         ADI861
CINBF    EQU      X'82'           A BIN/FLP ERROR - ALLOWED             ADI721
CINCO    EQU      8               A COMPUTATIONAL USAGE ONLY            ADI562
CINDU    EQU      X'C8'           A NUMERIC/DISPLAY USAGE               ADI631
CINDX    EQU      X'80'           A NON-DISPLAY ERROR - ALLOWED         ADI641
CINEJ    EQU      X'1000'         A NO EDITING/JUSTIFICATION            ADI348
CINE     EQU      X'10'           A NUMERIC EDITED                      ADI503
CINIO    EQU      X'20'           A INTEGER ONLY                        ADI663
CINU     EQU      X'48'           A NUMERIC USAGE                       ADI564
CIXDX    EQU      3               A INDEX DATA USAGE ERROR - ALLOWED    ADI707
CIXD     EQU      4               A INDEX DATA ALLOWED                  ADI703
CIXND    EQU      6               A INDEX NAME/DATA ALLOWED             ADI245
CIXNX    EQU      1               A INDEX USAGE ERROR - ALLOWED         ADI253
CITC     EQU      X'10000'          TRUNCATION
CISAV    EQU      X'80000'          SAVE REF FLAG                       ADI455
* DATA CLUSTER CLNG,CNTL EQUIVALENCES
CJIA     EQU      X'F0981'        M AN   - ALPHANUMERIC                 ADI351
CJIAM    EQU      X'F0980'        M AN/ANJ CLNG,CNTL ADJ.               ADI402
CJIX     EQU      X'5098C'          INDEX
CJIB     EQU      X'4098D'          BIN - COMPUTATIONAL
CJIC1    EQU      X'3098E'          FLS - COMPUTATIONAL-1
CJIC2    EQU      X'2098F'          FLL - COMPUTATIONAL-2
CJICM    EQU      X'00980'          NC CLNG,CNTL ADJ.                   ADI6314
CJIDM    EQU      X'10980'          ND CLNG,CNTL ADJ.                   ADI5604
CJIFC    EQU      X'D0390'        M FIGCON CLNG,CNTL                    ADI805
CJIAL    EQU      X'D0691'          AN LIT ADJ.
CJIFL    EQU      X'D0392'          ALL '1 CHAR' ANLIT
CJIFZ    EQU      X'70394'        M FIGCON - ZERO                       ADI821
CJILZ    EQU      X'70395'          LITERAL ZERO - AN
CJINL    EQU      X'60598'          N LIT ADJ.
CJINT    EQU      X'60B9D'          INTEGER
CJIG     EQU      X'E0980'        M GROUP - GROUP                       ADI303
CJIEM    EQU      X'EFF80'        M ANE/ANEJ CLNG,CNTL ADJ.             ADI3934
CJINE    EQU      X'D85'          M NE  - NUMERIC EDITED                ADI511
CJLIT    EQU      X'60000'          LIT REF FLAG                        ADF041
CJZFM    EQU      X'200'          M NC ZERO FILL CNTL ADJ.              ADI622
CJIMN    EQU      X'C049F'          MNEMONIC NAME
*
CKBA     EQU      0                 ADDRESS RESOLUTION - BA             ADI421
CKWA     EQU      2                                      WA             ADI271
CKDA     EQU      3                                      DA             ADI745
CLOP     EQU      X'80'           A LAST OPERAND                        A
CMHB     EQU      X'C'            A MODIFY INCREMENT - HALF BYTE SHIFT  ADJ541
CNDIM    EQU      3               A NO. OF DIMENSIONS                   ADI312
CSMBF    EQU      24              A BYTE DISPLACEMENT FLP/BIN           ADJ219
CSXBH    EQU      8               A INDX TO BIN HW ADJ                  ADJ614
CSMBX    EQU      40              A BYTE DISPLACEMENT INDX              ADJ238
IDCS     EQU      X'49045'          CONDITION NAME REF CONTROL          COBOL41P
* REFERENCES                       "REF"                                ADI
ADI00    RES      0                                                     ADI00
ADI02    RES      0
         LCI      6                 SAVE REGISTERS                      ADI01
         STM,L0   ADISAV                                                ADI02
         CI,R2    0                 CHECK CLOC                          ADI101
         BCS,CZ   ADI12             CLOC SET, CLUSTER READ              ADI102
         RCEF     ,,JRDF            READ NEXT CRF/ECF CLUSTER           ADI103
*                        R2 = HA(CLOC)                                  ADI11 2
ADI12    RES      0                                                     ADI120
         LW,R5    R2                SAVE HA(CLOC)-1                     ADI1202
         LI,R4    1                 LOAD HA(CLOC)+1                     ADI1204
         AW,R4    R2                                                    ADI1206
         LH,R7    0,R4              LOAD,SAVE OPERAND OPTIONS(OPT)      ADI121
         LH,R1    0,R2
         AND,R1   L(X'7F')          CONTROL BYTE
         LW,R6    PDBP
         CI,R6    X'2000'          SEE IF RGF CLUSTER
         BAZ      ADI04             NO
         LH,R6    JFDEC
         CI,R6    X'180'            SEE IF RGF DECLARATIVE CLUSTER
         BNE      ADI05             NO--PICK UP SUBSCPIPT FROM D-FLD
ADI04    RES      0
         CI,R1    X'74'
         BL       ADI10             NOT CORRESPONDING
         CI,R1    X'76'
         BG       ADI10             NOT CORRESPONDING
ADI05    RES      0
         LI,R1    X'60'
         AND,R1   R7                SUBSCRIPTS
         EOR,R7   R1                GET RID OF SUBSCRIPT BITS
         B        ADI11
ADI10    LH,R1    1,R2
         SLS,R1   -8                NO. OF SUBSCRIPT/INDEX
ADI11    LW,R6    R7
         SAS,R6   -12                                                   ADI123
         CI,R6    -7
         BE       ADI13             DATA-NAME
         LI,R1    0                 CLEAR NSUB
ADI13    STW,R1   NSUB
         LI,R1    X'FF'
         AND,R1   R7                MASK,LOAD STMT OPTION
         AND,R7   L(X'FFFFFF9F')
         EXU      ADI14+8,R6        EXECUTE ON OPTYP
* A*****INVALID REF OPTION********** COMPILER ERROR
* A*****UNASSIGNED/ILLEGAL REF OPTION***COMPILER ERROR
* S*****UNDEFINED DATA REF**********                                    ADI17
         B        ADI18                                                 ADI142
* OPTYP EXECUTE TABLE
ADI14    RES      0                                                     ADI140
         LI,R1    XDS+2       OPTYP=8 UNDEFINED(DATA ONLY)
         B        ADI20             9 NAME REF(-REF)                    ADI12402
         B        BADTYP            A
         B        ADI90             B NON-NUMERIC LITERAL(ANLIT)        ADI12404
         B        ADI84             C NUMERIC LITERAL(NLIT)             ADI12405
         B        ADI94             D INTEGER(ILIT)
         B        BADTYP            E
         B        BADTYP            F
         B        BADTYP            0
         B        BADTYP            1
         B        BADTYP            2
         B        ADI80             3 FIGURATIVE CONSTANT(FIGCON)       ADI12412
         B        BADTYP            4
         B        BADTYP            5
         B        BADTYP            6
         B        BADTYP            7
BADTYP   RES      0
         LI,R1    507
         BAL,L1   DIAG              COMPILER ERROR 07
         LI,R1    XDA+1
         B        ADI18
*
* S*****INVALID DATA USAGE**********                                    ADI15
ADI15    RES      0                                                     ADI150
         LI,R1    XDS               LOAD DIAG CODE                      ADI151
         B        ADI18                                                 ADI152
* S*****MAXIMUM SIZE EXCEEDED*******                                    ADI16
ADI16    RES      0                                                     ADI160
         LI,R1    XDS+1             LOAD DIAG CODE                      ADI161
         B        ADI18
* S*****INVALID DATA REF************
ADI17    RES      0
         LI,R1    XDS+3             LOAD DIAG CODE
* INVALID REFERENCE CLUSTER                                             ADI18
ADI18    RES      0                                                     ADI180
         LI,L1    ADN00             SET LINK REGISTER                   ADI182
         BAL,L0   *JRDF             CHECK FOR,SKIP SUBSCRIPTS/INDICES   ADI183
         LI,R4    0                 CLEAR OPLOC                         ADI184
* ERROR EXIT - RESTORE REGISTERS,RETURN                                 ADI19
ADI19    RES      0                                                     ADI190
         LCI      6                 RESTORE REGISTERS                   ADI191
         LM,L0    ADISAV                                                ADI192
         B        *L1               RETURN                              ADI193
* NAME REF
ADI20    RES      0                                                     ADI200
         STD,R6    SAV67                                                COBOL41P
         MTW,0    PDBDBG                                                COBOL41P
         BEZ      ADI21                                                 COBOL41P
         LH,R6    2,R2              PICK UP BASE                        COBOL41P
         LH,R7    2,R4              PICK UP DISPL                       COBOL41P
         STH,R6   R7                MERGE                               COBOL41P
         CW,R7    PDBDBG            SEE IF THIS IS DEBUG-CONTENTS       COBOL41P
         BE       ADI20A
         LW,R6    PDBDBG                                                COBOL35
         AI,R6    -53
         CW,R7    R6
         BNE      ADI21             NOT DEBUG-ITEM
         LH,R7    3,R4
         CI,R7    185               SEE IF REFERING TO WHOLE STRUCTURE
         BNE      ADI21             NO
         LW,R6    DBSIZE
         AI,R6    185-132
         B        %+2
ADI20A   RES      0
         LW,R6    DBSIZE            PICK UP MAX DEBUG SIZE              COBOL41P
         STH,R6   3,R4              STORE IN CRF CLUSTER                COBOL41P
ADI21    RES       0                                                    COBOL41P
         LD,R6     SAV67                                                COBOL41P
         CI,R7    CBND              CHECK FOR DATA NAME                 ADI201
         BCR,CB   ADI22             DATA NAME                           ADI202
* NOT DATA NAME
         CI,V2    X'40000'          CHECK CONDITION NAME FLAG
         BAZ      ADI17             DOWN. INVALID DATA.
         CI,R7    X'600'            CHECK FOR CONDITION NAME
         BANZ     ADI17             NO.
* CONDITION NAME
         LW,R6    R3                SAVE HA(STKTOP)
         LH,V0    0,R2              LOAD,POSITION CLNG
         SLS,V0   -8
         LH,V1    1,R4              LOAD, MASK NDIM
         AND,V1   K303
         AI,V1    8                 88 OFFSET = NDIM+8
         AW,R2    V1                HA(CLOC) = HA(CLOC)+88 OFFSET
         SW,V0    V1                C = CLNG-88 OFFSET
         STB,V0   R3                C TO MBS RU1
         STH,V0   12,R3             C TO 88 INFO. COUNT
         AI,R3    25                HA(STKTOP) TO HA(88STKLOC)
         AD,R2    R2                MBS R,RU1 TO BA
         MBS,R2   0                 88 INFO. TO STACK
         LW,R2    R5                RESTORE HA(CLOC),HA(STKTOP)
         LW,R3    R6
         LI,V2    IDCS+CISAV        LOAD CONDITION NAME REF CNTL
         MTW,1    ADISAV+1          SET CONDITION NAME RETURN
* DATA/MNEMONIC NAME
*                        R1 = STMT OPT                                  ADI2201
ADI22    RES      0
         LH,V1    3,R2              SAVE TDB NO.,KEY ORDER              ADI221
         STH,V1   JTDB                                                  ADI222
         LH,R6    1,R4              LOAD,SAVE NO. OF DIMENSIONS,(NDIM)  ADI224
         STB,R6   JNDIM                       ZERO FILL FLAG(ZFLG)      ADI225
         BCS,CM   ADI24             FILE/DD SECTION ITEM(DNAM)          ADI226
* NOT DNAM
         CI,R6    CDRN              CHECK FOR RECORD NAME(RNAM)         ADI227
         BCS,CB   ADI30             RNAM                                ADI228
* *** RECORD NAME ENTRY CANNOT BE INDEX***
* MNEMONIC NAME
         STH,R1   1,R2              STORE STMT OPT
         LW,V0    R6                SAVE TYPE
         SLS,R6   -8                POSITION MNEMONIC NAME TYPE
         EXU      ADI23,R6
         BAZ      ADI17             INVALID MNEMONIC NAME USAGE
* VALID MNEMONIC NAME USAGE
         LI,R6    CJIMN             LOAD MNAM CLNG,CNTL
         MTW,1    ADISAV+1          SET MNEMONIC NAME RETURN
         OR,R7    NSUB              RECOVER SUBSCRIPT INFORMATION
         LI,R2    0                 NLOC = 0
         B        ADI44+2
ADI23    RES      0
         B        ADI17             0 INVALID MNEMONIC NAME USAGE
         CI,V2    X'40000'          1 CHECK STATUS SWITCH FLAG
         CI,V2    X'40000'          2 CHECK STATUS SWITCH FLAG
         CI,V2    X'20000'          3 CHECK VALUE FLAG
* DNAM
ADI24    RES      0                                                     ADI240
         CI,R6    CDIXN             CHECK FOR INDEX NAME                ADI241
         BCS,CE   ADI30             NO.                                 ADI242
* INDEX NAME                                                            ADI243
         STH,R1   1,R2              STORE STMT OPT
         OR,R7    NSUB              RECOVER SUBSCRIPT INFORMATION
         CI,V2    CIXND             PROPER INDEX NAME USAGE             ADI245
         BCS,CB   ADI26             YES.                                ADI246
* W*****ILLEGAL INDEX NAME USAGE****                                    ADI25
         LI,R1    XDW               LOAD DIAG CODE                      ADI251
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI252
         CI,V2    CIXNX             CHECK IF INDEX NAME ALLOWED         ADI253
         BCS,CB   ADI26             YES. USE AS INDEX NAME              ADI254
         CI,V2    CIGPO             CHECK FOR GROUP ONLY                ADI255
         BCR,CB   ADI76             NO. PROCESS AS BIN DATA.            ADI256
         B        ADI33             PROCESS AS GROUP                    ADI257
* INDEX NAME ALLOWED                                                    ADI26
ADI26    RES      0                                                     ADI260
         LH,V0    4,R2              LOAD SUBSCRIPT FACTOR
         LB,V1    JTDB              LOAD TDB NO
         LI,R6    CJIX              LOAD INDEX NAME CLNG,CNTL           ADI263
         LI,R2    0                 CLEAR NLOC
         B        ADI44                                                 ADI266
* GROUP/ELEMENTARY DATA                                                 ADI30
ADI30    RES      0                                                     ADI300
         LCI      4
         STM,R4   VRSAV
         MTW,0    CORRF
         BEZ      ADI27             NOT CORRESPONDING
         MTW,0    ECFRF
         BEZ      ADI29             CRF CLUSTER
         MTW,-1   ECFRF
ADI27    LW,R6    VPCNT
         CI,R6    200                                                   COBOL41P
         BL       ADI28             ENOUGH BUFFER LEFT
         STH,R1   1,R2              STMT OPTION
         LI,R1    122
         BAL,L1   DIAG
         B        ADI291
ADI28    LH,R4    1,R2
         AND,R4   L(X'FF')          DISP OF VAR PARAM
         BNEZ     ADI281
         STW,R4   VPDSP,R6
         B        ADI29-1
ADI281   LW,R5    VPAA
         STW,R5   VPDSP+1,R6        INDEX
         SLS,R4   -1
         AW,R4    R2
         LH,R7    0,R4
         SLS,R7   -1
         STW,R7   VRSAV+4           LNTH OF VAR PARAM
         SLS,R7   -1
         AWM,R7   VPAA              UPDATE VPAA
         STB,R7   R5
         SLS,R5   2
         AW,R4    R4
         MBS,R4   0                 MOVE IN PARAM
         LI,R7    VPDSP
         AW,R7    R6
         AW,R7    L(X'01000000')
         SLS,R7   2
         LW,R6    R2
         AW,R6    R6
         MBS,R6   8                 SAVE DISPLACEMENT
         SLS,R2   1
         LB,R6    0,R2
         SW,R6    VRSAV+4
         STB,R6   0,R2              RESET A OF CRF
         SLS,R2   -1
         MTW,2    VPCNT
ADI29    STH,R1   1,R2              STMT OPTION
ADI291   LCI      4
         LM,R4    VRSAV
         OR,R7    NSUB              RECOVER SUBSCRIPT INFORMATION
         CI,V2    CIGPO             CHECK FOR GROUP ONLY                ADI301
         BCR,CB   ADI32             NO. ELEMENTARY ITEM ALLOWED         ADI302
* GROUP ONLY                                                            ADI303
         CI,R6    CDCL              CHECK FOR ELEMENTARY ITEM           ADI304
         BCR,CB   ADI33             NO. GROUP.                          ADI305
* W*****ILLEGAL ELEMENTARY ITEM USAGE***                                ADI306
*        LI,R1    XDW-1             LOAD DIAG CODE                      ADI307
*        BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI308
         AND,R6   K303              MASK,STORE NDIM
         STB,R6   JNDIM
         B        ADI33             TO COMPLETE GROUP ITEM              ADI309
*                        R6 = TYPE,CLASS                                ADI32 6
ADI32    RES      0                                                     ADI320
         AND,R6   K20F              RETAIN CLASS ONLY                   ADI321
         BCS,CA   ADI34             NOT GROUP                           ADI322
* GROUP                                                                 ADI3230
         CI,V2    CIGP              GROUP ALLOWED                       ADI324
         BCS,CB   ADI33             YES.                                ADI325
         CI,V2    CIGPX             GROUP USABLE(AS AN)                 ADI326
         BCR,CB   ADI15             NO. INVALID USAGE.                  ADI327
* W*****ILLEGAL GROUP USAGE*********                                    ADI3270
*        LI,R1    XDW-2             LOAD DIAG CODE                      ADI328
*        BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI329
ADI33    RES      0                                                     ADI330
         LI,R6    CJIG              LOAD GROUP CLNG,CNTL                ADI331
         B        ADI42             TO COMPLETE GROUP ITEM              ADI333
* ELEMENTARY DATA                                                       ADI34
ADI34    RES      0                                                     ADI340
         STW,V0   TMPV0
         LI,V0    0                 RESET FLAG
         STW,V0   DIVDF
         LH,V0    0,R2
         AND,V0   L(X'7F')
         CI,V0    X'56'
         BNE      ADI341            NOT DIVIDE
         MTW,1    DIVDF
         LH,V0    1,R5
         AND,V0   L(X'80')
         STW,V0   LDVDP             SET LAST CLUSTER FLAG
         LH,V0    1,R5
         AND,V0   L(X'10')          REMAINDER BIT
         CI,V0    X'10'
         BNE      ADI341            NO REMAINDER
         MTW,1    REMDR
ADI341   LW,V0    TMPV0
         CI,R6    CDNC              CHECK FOR NUMERIC COMPUTATIONAL     ADI341
         BCS,CB   ADI60             NUMERIC COMPUTATIONAL(NC)           ADI342
         CI,R6    CDNE              CHECK FOR NUMERIC                   ADI343
         BCS,CG   ADI56             NUMERIC DISPLAY(ND)                 ADI344
         BCR,CE   ADI50             NUMERIC EDITED(NE)                  ADI345
* ALPHANUMERIC(AN)/ALPHANUMERIC EDITED(ANE)                             ADI3450
         CI,V2    CIAND             CHECK IF AN/ANE ALLOWED             ADI346
         BCS,CB   ADI36             YES. AN ALLOWED                     ADI347
         CI,V2    CINEJ             CHECK FOR NO EDIT/JUSTIFICATION     ADI348
         BCR,CB   ADI15             NO. INVALID AN USAGE                ADI349
* AN - NO EDIT/JUSTIFICATION                                            ADI35
ADI35    RES      0                                                     ADI350
         LI,R6    CJIA              LOAD AN CLNG,CNTL                   ADI351
         B        ADI42             TO COMPLETE AN DATA ITEM            ADI352
ADI36    RES      0                                                     ADI360
         CI,R6    CDANE             CHECK FOR AN EDITED(ANE)            ADI361
         BCS,CL   ADI40             NO. NOT EDITED                      ADI362
* ALPHANUMERIC EDITED(ANE) - MAY BE JUSTIFIED                           ADI3620
         AW,R2    R2                SET BA(CLOC)                        ADI364
         LB,V0    0,R2              SAVE CLNG                           ADI365
         LB,R2    JNDIM             LOAD,CHECK NDIM(= DIM FLAG)         ADI366
         BCR,CZ   ADI37             NDIM = 0,NOT DIMENSIONED            ADI367
         AW,R5    R2                CLOC-1 = CLOC-1+NDIM                ADI368
         SW,V0    R2                REDUCE CLNG                         ADI369
         LW,R2    V0                REDUCED CLNG TO DIM FLAG            ADI3692
ADI37    RES      0                                                     ADI370
         LH,V1    4,R5              LOAD ACTUAL NO. OF CHAR.            ADI371
         CI,V2    CIAN              CHECK FOR AN USAGE                  ADI372
         BCS,CB   ADI39             YES. USE ANE.                       ADI373
*        CI,V1    CGMXD             CHECK DIGIT SIZE                    ADI376
*        BCS,CG   ADI15             > MAX COMP SIZE. INVALID USAGE      ADI377
* W*****ILLEGAL ANE USAGE***********                                    ADI38
ADI38    RES      0                                                     ADI380
         LI,R1    XDW-3             LOAD DIAG CODE                      ADI381
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI382
* COMPLETE ANE DATA ITEM                                                ADI39
ADI39    RES      0                                                     ADI390
         STH,V0   R6                FORM,POSITION CLNG,CNTL             ADI392
         SLS,R6   -8                                                    ADI393
         AI,R6    CJIEM                                                 ADI3934
         LI,V0    0                 SET DECP = 0                        ADI394
         BAL,L1   ADT00             CHECK TRUNCATION
         CI,R2    0                 CHECK DIM FLAG                      ADI395
         BCR,CZ   ADI43             DIM FLAG DOWN.                      ADI396
         STH,V0   4,R5              STORE DECP                          ADI397
         AI,R2    -9                COMPUTE EDIT INFO LNG               COBOL41P
         LI,L1    ADI48             LOAD LINK REGISTER                  ADI3994
         B        ADJ00             TO PROCESS SUBSCRIPTS               ADI399
* ALPHANUMERIC(AN)                                                      ADI40
ADI40    RES      0                                                     ADI400
         SLS,R6   -8                FORM AN/ANJ CLNG,CNTL               ADI401
         AI,R6    CJIAM                                                 ADI402
         CI,V2    CIAN              CHECK FOR AN/DISPLAY USAGE          ADI403
         BCS,CB   ADI42             AN/DISPLAY USAGE                    ADI404
*        LH,V1    3,R4              LOAD ACTUAL DIGIT SIZE(=SIZE)       ADI405
*        CI,V1    CGMXD             CHECK DIGIT SIZE                    ADI376
*        BCS,CG   ADI15             > MAX COMP SIZE. INVALID USAGE      ADI377
* W*****ILLEGAL AN USAGE************                                    ADI41
ADI41    RES      0                                                     ADI410
         LI,R1    XDW-4             LOAD DIAG CODE                      ADI411
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI412
* AN/GRP
ADI42    RES      0                                                     ADI420
         LI,V0    0                 SET DECP = 0                        ADI422
         LH,V1    3,R4              LOAD ACTUAL CHAR. SIZE(=SIZE)       ADI423
         BAL,L1   ADT00             CHECK TRUNCATION
         LB,R2    JNDIM             CHECK NDIM                          ADI424
         BCS,CZ   ADI68             NDIM NOT= 0, DIMENSIONED            ADI426
* COMPLETE BA DATA ITEM                                                 ADI43
ADI43    RES      0                                                     ADI430
         STH,V0   4,R5              STORE DECP                          ADI431
* NOT SUBSCRIPTED/INDEXED - COMPLETE DATA ITEM                          ADI44
*                        R2 = 0(=NLOC)
ADI44    RES      0                                                     ADI440
         STH,R2   1,R4              CLEAR SUBSCRIPT INFO.
         STH,V1   3,R5              STORE ACTUAL NO. OF CHAR/DIGITS     ADI443
         STH,R6   0,R4              STORE CLNG,CNTL                     ADI441
* *** ORDERED FOR MNEMONIC NAMES******
         CI,R7    CBSUB             CHECK NO. OF SUBSCRIPTS/INDICES(NSUBADI445
         BCR,CB   ADI46             NSUB = 0                            ADI446
* S*****INVALID SUBSCRIPTS/INDICES**                                    ADI45
ADI45    RES      0                                                     ADI450
         LI,R1    XSS               LOAD DIAG CODE                      ADI4504
         LI,L1    ADN00             SET LINK REGISTER                   ADI451
         BAL,L0   ADM02             SAVE REF, SKIP SUBSCRIPTS/INDICES   ADI452
         B        ADI48                                                 ADI453
ADI46    RES      0                                                     ADI454
         CI,V2    CISAV             CHECK SAVE FLAG                     ADI455
         BCR,CB   ADI48             SAVE FLAG DOWN                      ADI456
         BAL,L1   ADM02             SAVE REF ITEM                       ADI457
ADI48    RES      0                                                     ADI460
* NORMAL RETURN                                                         ADI46
         LCI      6                 RESTORE REGISTERS                   ADI461
         LM,L0    ADISAV                                                ADI4614
         LI,R1    1                 SET REG FOR NORMAL RETURN           ADI4618
         B        *L1,R1            RETURN                              ADI463
* NUMERIC EDITED                                                        ADI50
ADI50    RES      0                                                     ADI500
         CI,V2    CINEJ             CHECK FOR NO EDIT                   ADI501
         BCS,CB   ADI35             NO EDIT,USE AS AN                   ADI502
         CI,V2    CIANO             CHECK FOR AN ONLY                   ADI5022
         BCS,CB   ADI15             YES. INVALID NE USAGE               ADI5024
         CI,V2    CINE              NUMERIC EDITED ALLOWED              ADI503
         BCS,CB   ADI51             YES.                                ADI504
         CI,V2    CINDX             NE USABLE                           ADI506
         BCR,CB   ADI15             NO. INVALID NE USAGE                ADI507
* W*****ILLEGAL NE DATA USAGE*******                                    ADI508
         LI,R1    XDW-10            LOAD DIAG CODE                      ADI509
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI5092
ADI51    RES      0                                                     ADI510
         LI,R6    CJINE             LOAD NE CLNG,CNTL                   ADI511
         LB,R2    JNDIM             CHECK NDIM                          ADI513
         BCR,CZ   ADI52             NDIM = 0, NOT DIMENSIONED           ADI514
         AW,R5    R2                CLOC-1 = CLOC-1+NDIM                ADI515
         LI,R2    CELNG             LOAD EDIT INFO LNG(DIM FLAG)        ADI516
ADI52    RES      0                                                     ADI520
         LH,V0    5,R5              LOAD,MASK DSIZ
         LI,V1    X'3F'
         AND,V1   V0
         EOR,V0   V1                CLEAR DSIZ, RESTORE EDIT INFO.
         STH,V0   5,R5
         LH,V0    4,R5              LOAD DECP
         BAL,L1   SVDCP1
         BAL,L1   ADT00             CHECK TRUNCATION
         CI,R2    0                 CHECK DIM FLAG                      ADI524
         BCR,CZ   ADI43             DIM FLAG DOWN                       ADI525
ADI53    RES      0                                                     ADI530
         BAL,L1   ADJ00             PROCESS SUBSCRIPTS(BA,EDIT)         ADI531
         B        ADI48                                                 ADI532
* NUMERIC DISPLAY(NDS/NDU)                                              ADI556
ADI56    RES      0                                                     ADI560
         CI,V2    CIANO             AN ONLY
         BANZ     ADI15             YES.
         SLS,R6   -8                FORM ND CLNG,CNTL                   ADI5602
         AI,R6    CJIDM                                                 ADI5604
         LH,V1    3,R4              LOAD NO. OF DIGITS(DSIZ)            ADI563
         CI,V2    CINU              CHECK FOR NUMERIC USAGE             ADI564
         BCR,CB   ADI65             NO. DISPLAY USAGE.                  ADI565
         CI,V1    CGMXC             CHECK FOR MAX COMP SIZE             ADI566
         BCR,CG   ADI65             </= MAX COMP SIZE                   ADI567
         CI,V2    CINCO             CHECK FOR COMP USAGE                ADI568
         BCS,CB   ADI16             > MAX COMP SIZE. INVALID.           ADI569
         CI,V1    CGMXD             CHECK FOR MAX DISPLAY SIZE          ADI571
         BCR,CG   ADI65             </= MAX DISPLAY SIZE                ADI572
         B        ADI16             > MAX DISPLAY SIZE. INVALID.        ADI573
* NUMERIC COMPUTATIONAL                                                 ADI60
ADI60    RES      0                                                     ADI600
         CI,V2    CIADO             CHECK FOR AN/DISPLAY USAGE ONLY     ADI601
         BCS,CB   ADI15             YES. INVALID USAGE                  ADI602
         CI,R6    CDFXL             CHECK FOR FIXED LNG DATA            ADI603
         BCS,CB   ADI70             YES. FIXED LNG DATA                 ADI604
* PACKED DECIMAL(NC)                                                    ADI61
ADI61    RES      0                                                     ADI610
         LH,V1    3,R4              OBTAIN ACTUAL NO. OF DIGITS(DSIZ)   ADI611
         AW,V1    V1                DSIZ = BYTE LNG * 2 - 1             ADI612
         AI,V1    -1                                                    ADI613
         LH,V0    1,R4              CHECK FOR ZERO FILL                 ADI614
         CI,V0    CDZF                                                  ADI615
         BCR,CB   ADI63             NO.                                 ADI616
ADI62    RES      0                                                     ADI620
         AI,V1    -1                YES. DSIZ = DSIZ-1                  ADI621
         AI,V0    -CDZF             CLEAR ZERO FILL IND.                ADI623
         STB,V0   JNDIM                                                 ADI624
ADI63    RES      0                                                     ADI630
         SLS,R6   -8                FORM NC CLNG,CNTL                   ADI6312
         AI,R6    CJICM                                                 ADI6314
         CI,V2    CINDU             NUMERIC/DISPLAY USAGE               ADI631
         BCR,CB   ADI65             NO. NOT KNOWN.                      ADI632
         CI,V1    CGMXC             CHECK DSIZ                          ADI633
         BCR,CG   ADI64             < MAX COMP SIZE.                    ADI634
         CI,V2    CINCO             CHECK FOR COMP USAGE ONLY           ADI635
         BCS,CB   ADI16             YES. INVALID.                       ADI636
         CI,V1    CGMXD             CHECK FOR MAX DISPLAY SIZE          ADI637
         BCS,CG   ADI16             > MAX DISPLAY SIZE. INVALID.        ADI638
ADI64    RES      0                                                     ADI640
         CI,V2    CINDX             CHECK FOR NON-DISPLAY ERROR         ADI641
         BCR,CB   ADI65             NO.                                 ADI642
* W*****ILLEGAL NC USAGE************                                    ADI643
         LI,R1    XDW-5             LOAD DIAG CODE                      ADI644
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI645
ADI65    RES      0                                                     ADI650
         LB,R2    JNDIM             LOAD,CHECK NDIM(=DIM FLAG)          ADI652
         BCR,CZ   ADI66             NDIM = 0, NOT DIMENSIONED           ADI653
         AW,R5    R2                INCREMENT CLOC                      ADI654
ADI66    RES      0                                                     ADI660
         LH,V0    4,R5              LOAD DECP                           ADI661
         BCR,CZ   ADI67             DECP = 0, INTEGER                   ADI662
         CI,V2    CINIO             CHECK FOR INTEGER ONLY              ADI663
         BCR,CB   ADI67             NO.                                 ADI664
* W*****ILLEGAL NON-INTEGER USAGE***                                    ADI6640
*                                                                       COBOL41P
* THE FOLLOWING 6 INSTRUCTIONS PERMIT THE USE OF NON-INTEGER VALUES     COBOL41P
* FOR THE PERFORM STATEMENT. THIS IS NECESSARY TO PASS THE NAVY COBOL   COBOL41P
* TESTS ALTHOUGH IT VIOLATES ANS SPECS.                                 COBOL41P
*                                                                       COBOL41P
         LW,R1    R4                HA(CLOC)+1                          COBOL41P
         AW,R1    R1                BA                                  COBOL41P
         AI,R1    -1                                                    COBOL41P
         LB,R1    0,R1              IF CONTROL BYTE = 61 (PERFORM),     COBOL41P
         CB,R1    L(X'61000000')    ALLOW NON-INTEGER VALUES            COBOL41P
         BE       ADI67                                                 COBOL41P
         LI,R1    XDW-6             LOAD DIAG CODE                      ADI665
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI666
ADI67    RES      0                                                     ADI670
         BAL,L1   SVDCP1
         BAL,L1   ADT00             CHECK TRUNCATION
         CI,R2    0                 CHECK DIM FLAG                      ADI673
         BCR,CZ   ADI43+1           TO COMPLETE ND/NC DATA ITEM         ADI674
ADI68    RES      0                                                     ADI680
         BAL,L1   ADJ02             TO PROCESS SUBSCRIPTS/INTEGER       ADI681
         B        ADI48                                                 ADI682
* FIXED LENGTH DATA ITEM                                                ADI70
ADI70    RES      0                                                     ADI700
         CI,R6    CDNIX             CHECK FOR INDEX DATA
         BANZ     ADI72             NO. BIN/FLP
         CI,V2    CIXD              PROPER INDEX DATA USAGE             ADI703
         BCS,CB   ADI71             YES.                                ADI704
* W*****ILLEGAL INDEX DATA USAGE****                                    ADI7040
         LI,R1    XDW-7             LOAD DIAG CODE                      ADI705
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI706
         CI,V2    CIXDX             CHECK IF INDEX DATA ALLOWED         ADI707
         BCS,CB   ADI71             YES. USE AS INDEX DATA              ADI708
         B        ADI76             NO. USE AS BIN DATA                 ADI709
* INDEX DATA                                                            ADI71
ADI71    RES      0                                                     ADI710
         LI,V0    0                 TDB NO.,SUBSCRIPT FACTOR = 0
         LI,V1    0
         LI,R6    CJIX              LOAD INDEX DATA CLNG,CNTL           ADI714
         B        ADI77                                                 ADI716
* BIN/FLP DATA                                                          ADI72
ADI72    RES      0                                                     ADI720
         CI,V2    CINBF             CHECK FOR PROPER USAGE              ADI721
         BCR,CB   ADI73             YES.                                ADI722
* W*****ILLEGAL BIN/FLP USAGE*******                                    ADI7220
         LI,R1    XDW-8             LOAD DIAG CODE                      ADI723
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI724
         CI,R6    CDFPS             CHECK CLASS                         ADI725
         BCS,CL   ADI76             BIN DATA                            ADI726
         B        ADI74             FLOATING POINT DATA                 ADI727
ADI73    RES      0                                                     ADI730
         CI,R6    CDFPS             CHECK CLASS                         ADI731
         BCS,CL   ADI76             BIN DATA                            ADI732
         CI,V2    CINIO             CHECK FOR INTEGER ONLY              ADI733
         BCR,CB   ADI74             NO.                                 ADI734
* W*****FLOATING POINT USAGE FOR INTEGER***                             ADI7340
         LI,R1    XDW-9             LOAD DIAG CODE                      ADI7344
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADI735
ADI74    RES      0                                                     ADI740
         LI,V0    7
         BAL,L1   SVDCP
         LI,V0    X'7FFF'           SET DECP TO MAX                     ADI7404
         CI,R6    CDFPS             CHECK CLASS                         ADI741
         BCR,CE   ADI75             FPS.                                ADI742
* FPL DATA                                                              ADI7420
         LI,R6    CJIC2             LOAD FPL CLNG,CNTL                  ADI743
         LI,V1    CGFLS                  DSIZ                           ADI744
         LI,R1    -CKDA                  DA INDICATION                  ADI745
         B        ADI78                                                 ADI746
* FPS DATA                                                              ADI75
ADI75    RES      0                                                     ADI750
         LI,R6    CJIC1             LOAD FPS CLNG,CNTL                  ADI751
         LI,V1    CGFSS                  DSIZ                           ADI752
         B        ADI77                                                 ADI753
* BIN DATA                                                              ADI76
ADI76    RES      0                                                     ADI760
         LI,R6    CJIB              LOAD BIN CLNG,CNTL                  ADI761
         LI,V1    CGBSZ                  SIZD                           ADI762
         LI,V0    0                      DECP(=0,INTEGER)               ADI763
         BAL,L1   SVDCP1
         BAL,L1   ADT00             CHECK TRUNCATION
ADI77    RES      0                                                     ADI770
         LI,R1    -CKWA             LOAD WA INDICATION                  ADI771
ADI78    RES      0                                                     ADI780
         LB,R2    JNDIM             CHECK NDIM                          ADI782
         BEZ      ADI43             NDIM = 0, NOT DIMENSIONED
         BAL,L1   ADJ02+1           TO PROCESS SUBSCRIPTS
         B        ADI48                                                 ADI785
* FIGURATIVE CONSTANT(FIGCON)                                           ADI80
*                        R7 = OPT                                       ADI80 7
ADI80    RES      0                                                     ADI800
         LW,V1    R7                SAVE FIGCON REF TYPE                ADI803
         AI,V1    -X'3000'                                              ADI804
         LI,R6    CJIFC             LOAD FIGCON CLNG,CNTL               ADI805
         CI,V1    X'F00'            CHECK FIGCON TYPE
         BAZ      ADI82             ZERO
* NOT ZERO
         CI,V2    X'40000'          COND.
         BAZ      ADI83             NO
         CI,V2    CINU              NUMERIC ONLY
         BAZ      ADI83             NO
* S*****FIGCON NOT ALLOWED
         B        ADI15
ADI82    RES      0                                                     ADI820
         LI,R6    CJIFZ             LOAD ZERO CLNG,CNTL                 ADI821
*                        R1 = OPTION
*                        R6 = CLNG,CNTL
*                        V1 = FIGCON TYPE/ALL CHAR.
ADI83    RES      0
         STH,V1   1,R5              STORE FIGCON TYPE/CHAR.
         LI,V1    1                 BSIZ = 1
         STH,R1   0,R4              STORE OPTION
         LI,R2    0                 CLEAR NLOC
         AI,R4    -1                SET HA(CLOC),HA(CLOC)-1
         BDR,R5   ADI44+2
* NUMERIC LITERAL(N LIT)                                                ADI84
ADI84    RES      0                                                     ADI840
         CI,V2    CIANO             AN ONLY
         BANZ     ADI15             YES
         LH,V0    1,R2              LOAD DECP,BYTE LNG                  ADI841
         SLD,V0   -8                POSITION DECP,BYTE LNG              ADI842
         LB,V1    V1                LOAD,SAVE BYTE LNG(BSIZ)            ADI843
         LI,L1    X'F'
         AND,L1   V1                *  (=L)
         AW,V1    V1                COMPUTE ACTUAL DIGIT SIZE(DSIZ)     ADI846
         AI,V1    -1                                                    ADI847
         SLS,L1   4                 POSITION BSIZ                       ADI851
         AI,L1    X'17E08'          FORM DL,BSIZ 1,R4 SKELETON
         AI,R3    1                 HA(STKTOP) = HA(STKTOP)+1            2
         STH,L1   3,R3              STORE DL INSTR. SKELETON             3
         SCS,L1   16                POSITION DL,BSIZ 1,R4 INSTR.        ADI854
         AW,R4    R4                HA(CLOC)+1(=LITERAL LOC) TO BA      ADI855
         LB,D3    1,R4              LOAD,CHECK LEADING DIGIT
         CI,D3    X'F0'
         BANZ     ADI85             NOT= 0. S&GNIFICANT
* = 0,
         CI,R7     X'100'           SEE IF FIELD IS EVEN OR ODD         COBOL41P
         BANZ      ADI85            ODD NUMBER MUST BE SIGNIFICANT      COBOL41P
* *** LEADING ZERO DIGIT ASSUMED TO BE FILL CHAR ***
         AI,V1    -1                DSIZ = DSIZ-1
ADI85    RES      0
         EXU      L1                LOAD,TEST LITERAL VALUE             ADI856
         BNEZ     ADI86             NOT= 0
* ZERO LIT
         AI,R3    -1                RESET HA(STKTOP)
         SLS,R4   -1                BA(CLOC)+1 TO HA                    ADI8564
         CI,V2    CILC              CHECK FOR COMP USAGE                ADI861
         BCS,CB   ADI82             YES. FORM FIGCON,ZERO.              ADI862
         LI,R6    CJILZ             LOAD AN ZERO CLNG,CNTL              ADI863
* ** DECP TEST NOT PERFORMED *******
         AW,R2    R2                HA(CLOC) TO BA
         STB,V1   1,R2              STORE DSIZ
         B        ADI83+2
* N LIT
ADI86    RES      0
         LH,R6    0,R2              FORM NLIT CLNG,CNTL                 ADI8702
         AND,R6   K2FF                                                  ADI8704
         AI,R6    CJINL+1
         CI,V2    CINCO             CHECK FOR COMP USAGE ONLY           ADI871
         BAZ      ADI87             NO
         CI,V1    CGMXC+1           CHECK DIGIT SIZE                    ADI873
         BGE      ADI16             > MAX. COMP SIZE
ADI87    RES      0
         LW,R4    R3                LOAD HA(CLOC)
         AW,R4    R4                HA(CLOC) TO BA
         MTB,1    L1                DL(=X'7E') TO DST(=X'7F')           14
         AI,L1    3                 WORD OFFET(=1) = 4                  15
         EXU      L1                DST LITERAL                         16
         CI,D3    1                 CHECK SIGN
         BAZ      ADI88             POSITIVE, 'UNSIGNED'
* NEGATIVE, 'SIGNED'
         AI,R6    -1                LOWER 'UNSIGNED' FLAG
         AI,D3    -1                SET SIGN POSITIVE
ADI88    RES      0                                                     ADI880
         CI,V0    0                 CHECK DECP
         BNE      ADI89             NOT= 0, NOT INTEGER
* INTEGER
         DC,1     ADI48+1           CHECK INTEGER VALUE
* **                     = LM = X'2A' = D'+2'
         BGE      ADI89             >/= D'+2'
* INTEGER D'+/-1'
         AI,R6    2                 SET INTEGER D'+/-1' CNTL
*                        R3 = HA(STKTOP)+1
ADI89    RES      0                                                     ADI890
         STD,R3   R4                LOAD HA(CLOC),HA(CLOC)-1
         AI,R5    -1
*                        R1 = STMT OPT                                  ADI8901
*                        R4 = HA(CLOC)
*                        R5 = HA(CLOC)-1
*                        V0 = DECP
*                        V1 = DSIZ
         LI,R2    0                 RESET NLOC                          ADI892
         STH,R1   1,R5              STORE STMT OPT                      ADI894
         LI,R1    X'800'            LIT BASE = 8
         STH,R1   2,R5
         BDR,R3   ADI43             HA(STKTOP)-1 = HA(STKTOP)
* NON-NUMERIC LITERAL(AN LIT)                                           ADI90
ADI90    RES      0                                                     ADI900
         CI,V2    X'40000'          COND
         BAZ      ADI902            NO.
         CI,V2    CINU              NUMERIC ONLY
         BANZ     ADI15             YES
ADI902   RES      0
         LH,R6    0,R2              LOAD CLNG                           ADI901
         AND,R6   K2FF                                                  ADI902
         LH,V1    1,R2              LOAD BSIZ(,1ST CHAR)
         LI,R2    2                 SET BSIZ INDEX
         CI,R7    CBALL             CHECK FOR ALL OPTION                ADI903
         BCS,CB   ADI92             YES. ALL 'LIT'.                     ADI904
         AI,R6    CJIAL             SET AN LIT CNTL                     ADI905
ADI91    RES      0                                                     ADI910
         LB,V1    V1,R2             LOAD BSIZ
         LW,R5    R3                LOAD HA(STKTOP)+9
         AI,R5    9
         AD,R4    R4                RE,RO TO BA
         STB,V1   R5                STORE BSIZ
         MBS,R4   3                 MBS ANLIT
         AI,R3    1                 HA(STKTOP) = HA(STKTOP)+1
         STH,V1   3,R3              STORE BSIZ
         LAB,V0   ADI89,0           DECP = 0
* ALL 'LITERAL'                                                         ADI92
ADI92    RES      0                                                     ADI920
         AI,R6    CJIAL+2           LOAD ALL ANLIT CLNG,CNTL
         CI,V1    X'FE00'           CHECK BSIZ
         BANZ     ADI91             BSIZ > 1
* ALL '1 CHAR' LITERAL
         STB,V1   V1,R2             STORE CHAR.
         LI,R6    CJIFL             LOAD ALL '1 CHAR' CLNG,CNTL         ADI927
         B        ADI83
*                                                                        2
* INTEGER(ILIT)                                                          3
ADI94    RES      0                                                      4
         LH,V0    1,R4              LOAD,STORE INTEGER VALUE - 2ND HALF
         STH,V0   5,R3
         LH,V1    1,R5              LOAD INTEGER VALUE - 1ST HALF        8
         STH,V1   V0                COMBINE,CHECK VALUE
         CI,V0    0
         BEZ      ADI82             =0.
* NOT= 0
         LI,R6    CJINT             LOAD INTEGER CLNG,CNTL               5
         AI,R3    1                 HA(STKTOP) = HA(STKTOP)+1            9
         STH,V1   4,R3              STORE INTEGER VALUE - 2ND HALF
         LI,V1    4                 BSIZ = 4                            11
         STH,V1   3,R3
         LI,V1    CGBSZ             *    DSIZ                           14
         LAB,V0   ADI89,0           DECP = 0
SVDCP    CI,R6    CDFPS
         BCR,CE   SVDCP1
         AI,V0    8                 FLL
SVDCP1   MTW,0    DIVDF
         BEZ      *L1               NOT DIVIDE
         STW,V0   TMPV0
         MTW,0    REMDR
         BEZ      SVDCP2            NOT RFLD
         MTW,-1   REMDR
         AND,V0   L(X'FF')          RFLD DECP
         B        SVDCP3
SVDCP2   MTW,0    LDVDP
         BEZ      *L1               NOT LAST CLUSTER
         AND,V0   L(X'FF')          REMDR DECP
         SLS,V0   8
SVDCP3   OR,V0    RDECP
         STW,V0   RDECP             SAVE DECPS
         LW,V0    TMPV0
         B        *L1
         PAGE
* SUBSCRIPTS/INDICES               "SUBS"                               ADJ
* EDITED DATA FIELD                                                     ADJ0
ADJ00    RES      0                                                     ADJ00
*                        R2 = HA(EDIT INFO(EINFO)LNG(ELNG))             ADJ0002
*                        R5 = HA(CLOC)+NDIM                             ADJ0005
*                           = HA(EINFO LOC(ELOC)-CONST INFO(CINFO)LNG)  ADJ0006
         LW,V2    R3                SAVE STKTOP(=HA(CLOC)-1)            ADJ001
         STB,R2   R3                ELNG TO MBS RU1                     ADJ002
         LW,R2    R5                MBS R = ELOC                        ADJ003
         AI,R3    CACHL             STKTOP = STKTOP+CINFO LNG           ADJ004
         AD,R2    R2                ELOC,ELNG,STKTOP TO BA              ADJ005
         MBS,R2   CACBL             MOVE EDIT INFO, STKTOP UPDATED      ADJ006
         SLS,R3   -1                BA(UPDATED STKTOP) TO HA            ADJ007
         LI,R1    0                 LOAD BA INDICATION                  ADJ008
         B        ADJ04                                                 ADJ009
* NON-EDITED DATA FLDS
ADJ02    RES      0                                                     ADJ020
         LI,R1    0                 LOAD BA INDICATION
         STH,V0   4,R3              STORE DECP                          ADJ021
         LW,V2    R3                SAVE STKTOP(=HA(CLOC)-1)
         AI,R3    CACHL+1           UPDATE STKTOP                       ADJ031
ADJ04    RES      0                                                     ADJ040
*                        V2 = STKTOP(=HA(CLOC)-1)                       ADJ0401
         LW,R5    V2                LOAD HA(CLOC)-1                     ADJ042
         LI,R2    CACHL-2           CINFO LNG-2 TO MBS RU1              ADJ043
         STB,R2   R5                                                    ADJ044
         AI,R5    2                 STKTOP = STKTOP+2                   ADJ045
         AD,R4    R4                CLOC,CINFO LNG-2,STKTOP TO BA       ADJ046
         MBS,R4   2                 MOVE CINFO TO OPSTK                 ADJ047
         LW,R5    V2                LOAD HA(CLOC)-1                     ADJ051
         XW,R4    V2                SET HA(CLOC),SAVE BA(SUBF LOC)      ADJ052
         AI,R4    1                                                     ADJ053
         STH,R6   0,R4              STORE CLNG,CNTL                     ADJ054
         STH,V1   3,R5                    DSIZ/TDB                      ADJ056
         LI,R2    CBSUB             CHECK NSUB                          ADJ057
         AND,R2   R7                                                    ADJ058
         BCS,CA   ADJ07             NSUB NOT = 0, SUBSCRIPTED/INDEXED   ADJ059
* W*****DIMENSIONED DATA NOT SUBSCRIPTED/INDEXED***                     ADJ06
         LI,R1    XSW               LOAD DIAG CODE
* CORRESPONDING SWITCH
         B        *JMCSX            DIAG/CORRESPONDING
         B        AEC40             CORRESPONDING
ADJ06    RES      0
         BAL,L1   DIAG              WRITE DMF CLUSTER
         STH,R2   1,R4              CLEAR SUBSCRIPT INFO
         LAB,L1   *JRDF,ADI48       READ NEXT CLUSTER
* SUBSCRIPTED/INDEXED DATA                                              ADJ07
ADJ07    RES      0                                                     ADJ070
         EOR,R7   R2                CLEAR NSUB                          ADJ0704
         LCI      8                 SAVE REGISTERS                      ADJ071
         STM,R4   ADJSAV                                                ADJ072
         STH,R6   JCLNG             SAVE CLNG                           ADJ073
         SLS,R2   -5                POSITION NSUB                       ADJ074
         LB,R7    JNDIM             LOAD NDIM                           ADJ075
         SW,R7    R2                NSUBX = NDIM-NSUB                   ADJ076
         STH,R7   JNSUBX            SAVE NSUBX                          ADJ077
         BCR,CM   ADJ08             NSUB </= NDIM                       ADJ078
         AW,R2    R7                NSUB > NDIM, SET NSUB = NDIM        ADJ079
* SAVE SUBSCRIPT FACTORS(SUBF)                                          ADJ08
*                        R1 = ADDR RESOLUTION INDICATOR                 ADJ08 1
*                        V2 = BA(SUBF LOC)                              ADJ08 8
ADJ08    RES      0                                                     ADJ080
         LW,R7    R2                SAVE NSUB                           ADJ081
         LW,R6    V2                BA(SUBFLOC) TO INDEX REG.           ADJ0814
         SLS,R6   -1                BA(SUBFLOC) TO HA                   ADJ082
         AW,R2    R2                NSUB = NSUB*2                       ADJ084
ADJ09    RES      0                                                     ADJ090
         AI,R6    1                 SUBFLOC = SUBFLOC+1
         LH,V2    0,R6              LOAD SUBF(I)                        ADJ092
         SLS,V2   0,R1              ADJUST BA(SUBF)                     ADJ093
         AI,R2    -1                SET HA(SUBF(I))                     ADJ094
         STH,V2   JSUBF,R2          SAVE SUBF(I)                        ADJ095
         BDR,R2   ADJ09             HA(SUBF(I)) = HA(SUBF(I))-1         ADJ096
         STW,R1   JADDR             SAVE ADDR RESOLUTION INDICATOR      ADJ097
         LB,R2    JTDB              CHECK TDB(=TDB(3))                  ADJ101
         BEZ      ADJ12             TDB = 0, NON-TABLE ITEM
         LH,R6    *PDBZ+4,R2        LOAD TDB LOC                        ADJ103
         SLS,R6   -2                BA DISPL TO WA
         AI,R6    1                                                     ADJ1032
         LW,V2    *PDBZ+3,R6        LOAD TDB(2),TDB(1)                  ADJ104
         LH,V2    V2                                                    ADJ1044
         STH,R2   V2                POSITION TDB(3),TDB(2),TDB(1)       ADJ105
         LW,R2    V2                                                    ADJ106
ADJ12    RES      0
         STW,R2   JTDBN             STORE/CLEAR TDBN                    ADJ111
         LI,V2    0                 CLEAR SUBSCR TYPE IND.(DTYP)
         STW,V2   JINVS             CLEAR INVARIANT SUBSCRIPTS(INVS)
         STH,V2   JTSH              INITIALIZE TYPE CONTROL SHIFT       ADJ117
         LW,R6    R3                SAVE HA(SLOC)                       ADJ118
*                        R3 = HA(SLOC)
*                        R6 = HA(SLOC)                                  ADJ1196
*                        R7 = NSUB                                      ADJ1197
*                        V2 = DTYP                                      ADJ1198
*                        V0,V1,L1 - VOLATILE                            ADJ1199
ADJ13    RES      0                                                     ADJ130
         RCRF     R5                READ NEXT CLUSTER                   ADJ131
ADJ14    RES      0                                                     ADJ140
         LH,V1    0,R5              LOAD,CHECK OPTYP                    ADJ141
         CI,V1    CBSDN                                                 ADJ142
         BCR,CE   ADJ34             SUBSCRIPT DATA NAME                 ADJ143
         CI,V1    CBSLT                                                 ADJ144
         BCR,CE   ADJ17             LITERAL SUBSCRIPT                   ADJ145
         BCS,CL   ADJ15             NOT INDEX INCREMNT/DECREMNT(IXI/IXD)ADJ146
         CI,V1    CBXDC                                                 ADJ147
         BCR,CG   ADJ13             IXI/IXD,IGNORE                      ADJ148
* S*****INVALID SUBSCRIPTS/INDICES**
ADJ15    RES      0                                                     ADJ150
         LI,R1    XSS+1             LOAD DIAG CODE                      ADJ151
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ152
         BDR,R7   ADJ13             NSUB = NSUB-1                       ADJ153
ADJ16    RES      0                                                     ADJ160
         RCRF     R1                READ NEXT CLUSTER                   ADJ161
         LH,V1    0,R1              LOAD,CHECK OPT                      ADJ162
         AI,V1    X'2D00'           -CBXDC
         BCR,CZ   ADJ16             IXD,IGNORE                          ADJ164
         AI,V1    X'100'                                                ADJ165
         BCR,CZ   ADJ16             IXI,IGNORE                          ADJ166
         B        ADJ20             TO COMPLETE SUBSCRIPT PROCESSING    ADJ167
* LITERAL SUBSCRIPTS                                                    ADJ17
ADJ17    RES      0                                                     ADJ170
         LH,D1    1,R5              LOAD INTEGER(INVF)                  ADJ171
         LH,V1    1,R2                                                  ADJ172
         STH,V1   D1                                                    ADJ173
         AI,D1    -1                INVF = INVF-1                       ADJ174
         MW,D1    JSUBF-1,R7        INVS(I) = INVF*(+/-SUBF(I))         ADJ175
ADJ18    RES      0                                                     ADJ180
         RCRF     R5                READ NEXT CLUSTER                   ADJ181
ADJ19    RES      0                                                     ADJ190
         AWM,D1   JINVS             INVS = INVS+INVS(I)                 ADJ191
         BDR,R7   ADJ14             NSUB = NSUB-1                       ADJ192
* NSUB = 0, E-O-SUBSCRIPTS/INDICES                                      ADJ193
ADJ20    RES      0                                                     ADJ200
         LD,R4    ADJSAV            RESTORE HA(CLOC),HA(CLOC)-1         ADJ203
         LW,V1    JINVS             LOAD,CHECK INVS                     ADJ243
         BEZ      ADJ23             INVS = 0
* INVARIANT SUBSCRIPTS
* CORRESPONDING SWITCH
         B        *JMCSI
         B        ADJ26             CORRESPONDING
ADJ22    RES      0
         LH,V0    2,R4              LOAD DISPLACEMENT(DISPL)            ADJ245
         LH,R1    2,R5
         STH,R1   V0
         LB,R1    V0                SAVE BASE NO
*                        R7 = 0
         STB,R7   V0                CLEAR BASE NO
         LCW,R7   JADDR             LOAD +ADDR. RES. IND.
         SLS,V1   0,R7              ALIGN INVS,DISPL
         AW,V0    V1                DISPL + INVS                        ADJ253
         BLZ      ADJ24             DISPL + INVS < 0, INVS NECESSARY
         CI,R1    X'FF'             CHECK FOR LINKAGE SECTION           COBOL41P
         BE        ADJ24            INVS  NECESSARY                     COBOL41P
* INVS + DISPL >/= 0
*                        R1 = BASE NO.
         STB,R1   V0                RESTORE BASE NO
         STH,V0   2,R4              STORE BASE NO.,NEW DISPL            ADJ263
         LH,V1    V0                                                    ADJ264
         STH,V1   2,R5                                                  ADJ265
         BAL,L1   ADJ65
* INVS = 0
ADJ23    RES      0
         CI,V2    0                 CHECK FOR VARIABLE SUBSCRIPTS/INDICEADJ266
         BNEZ     ADJ28             VARIABLE SUBSCRIPTS
* INVS ONLY
         STH,V2   1,R4              CLEAR SUBSCRIPT INFO.
         B        ADJ30
* DISPL-INVS < 0/BA,HA BITS AND VARIABLE SUBSCRIPTS
ADJ24    RES      0                                                     ADJ240
         LW,V1    JINVS             RELOAD INVS                         ADJ271
         CI,R7    0                 CHECK ADDR. RESOLUTION
         BNEZ     ADJ26             WA/DA DREF
* BA DREF
         LH,V0    2,R4              LOAD DISPL
         LI,R7    3                 MASK,CLEAR BA/HA BITS
         AND,R7   V0
         EOR,V0   R7
         STH,V0   2,R4
         BAL,L1   ADJ65
         AW,V1    R7                INVS = INVS+BA/HA BITS
*                        V1 = INVS
*                        V2 = VARIABLE SUBSCRIPTS INDICATOR
ADJ26    RES      0
         LH,R7    V1                STORE INVS                          ADJ273
         STH,V1   1,R3
         AI,R3    1                 UPDATE STKTOP                       ADJ275
         STH,R7   0,R3                                                  ADJ274
         AI,R3    1                 UPDATE STKTOP
         AI,V2    9                 SET INVS TYPE INDEX
* VARIABLE SUBSCRIPTS
ADJ28    RES      0                                                     ADJ280
         AI,R3    1                 SLOC = SLOC+1
         LB,R1    JCLNG             CLNG(=SLOC OFFSET+1) TO SFLG BYTE   ADJ282
         STH,R1   1,R4                                                  ADJ283
         LH,R7    JTSH              LOAD TYPE SHIFT                     ADJ284
         SLS,V2   12,R7             POSITION,STORE DTYP
         STH,V2   0,R6                                                  ADJ286
         AW,R4    R4                SET HA(CLOC) TO BA                  ADJ287
         SW,R6    R3                -(SINFO LNG) = SLOC-STKTOP          ADJ291
         SW,R1    R6                CLNG = CLNG+SINFO LNG               ADJ292
         STB,R1   0,R4              STORE NEW CLNG                      ADJ293
         SLS,R4   -1                SET BA(CLOC) TO HA                  ADJ294
ADJ30    RES      0                                                     ADJ300
         LCH,R1   JNSUBX            LOAD,CHECK NSUBX                    ADJ301
         BCR,CZ   ADJ32             NSUBX = 0,NSUB = NDIM               ADJ302
         BCS,CL   ADJ31             -NSUBX < 0, INSUFFICIENT            ADJ303
* S*****EXCESSIVE SUBSCRIPTS/INDICES***                                 ADJ304
         BAL,L0   ADN04             SKIP EXCESS SUBSCRIPTS/INDICES      ADJ306
         DX       XSS+2,ADJ32       WRITE DMF CLUSTER                   ADJ308
* W*****INSUFFICIENT SUBSCRIPTS/INDICES                                 ADJ31
ADJ31    RES      0                                                     ADJ310
         LI,R1    XSW-1             LOAD DIAG CODE                      ADJ311
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ312
ADJ32    RES      0                                                     ADJ320
         LCI      6                 RESTORE REGISTERS                   ADJ321
         LM,R6    ADJSAV+2                                              ADJ322
         B        *L1               RETURN                              ADJ323
* VARIABLE SUBSCRIPT/INDEX                                              ADJ34
ADJ34    RES      0                                                     ADJ340
         LH,D0    1,R5              LOAD,MASK OFF CLASS                 ADJ341
         LI,R4    CDCL                                                  ADJ342
         AND,R4   D0                                                    ADJ343
         CI,R4    CDNDC             CHECK CLASS                         ADJ344
         BCS,CL   ADJ15             INVALID CLASS USAGE                 ADJ345
         LH,D1    2,R2              LOAD BASE NO.,DISPL.                ADJ346
         LH,D2    2,R5                                                  ADJ347
         STH,D2   1,R3              STORE DISPL (2ND,3RD BYTES)
         AI,R3    1                 UPDATE STKTOP                       ADJ463
         STH,D1   0,R3              STORE BASE NO.,DISPL(1ST BYTE)      ADJ461
         LW,V0    JSUBF-1,R7        LOAD,STORE SUBF(I)                  ADJ462
         STH,V0   1,R3                                                  ADJ4624
         AI,R3    2                 UPDATE STKTOP
         LH,D3    3,R2              SAVE TDB NO.                        ADJ348
         LI,R1    CDIM              MASK OFF NDIM                       ADJ351
         AND,R1   D0                                                    ADJ352
         BCR,CA   ADJ36             NDIM = 0,NOT DIMENSIONED            ADJ353
         AW,R2    R1                CLOC = CLOC+NDIM                    ADJ354
* W*****DIMENSIONED SUBSCRIPT*******                                    ADJ355
         LI,R1    XSW-2             LOAD DIAG CODE                      ADJ356
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ357
ADJ36    RES      0                                                     ADJ360
         SLS,R4   -8                POSITION CLASS                      ADJ361
         EXU      ADJ39-6,R4        BRANCH ON CLASS
* NUMERIC DISPLAY                                                       ADJ37
         LH,V0    3,R5              LOAD BSIZ,DSIZ(=BSIZ)               ADJ371
         LW,V1    V0                                                    ADJ372
         CI,V0    CGMXD             CHECK BSIZ                          ADJ373
         BCR,CG   ADJ41             BSIZ </= MAX BYTE SIZE ALLOWED      ADJ374
* S*****MAX SUBSCRIPT DIGIT SIZE EXCEEDED***                            ADJ391
ADJ38    RES      0                                                     ADJ380
         LI,R1    XSS+3             LOAD DIAG CODE                      ADJ392
         AI,R3    -3                HA(SLOC) = HA(SLOC)-3
         B        ADJ15+1                                               ADJ394
ADJ39    RES      0                                                     ADJ390
         LI,R4    X'A'              NDS - LOAD CTYP
         LI,R4    X'A'              NDU - LOAD CTYP
         B        ADJ40             NCS
         B        ADJ40             NCU
         B        AAZ00             NOT ASSIGNED                        ADJ3630
         B        AAZ00             NOT ASSIGNED                        ADJ3631
         BDR,R3   ADJ60             INDEX - SLOC = SLOC-1
         B        ADJ50             BIN                                 ADJ3633
         B        ADJ59             FPS                                 ADJ3634
         B        ADJ59             FPL                                 ADJ3635
* COMPUTATIONAL-3                                                       ADJ38
ADJ40    RES      0                                                     ADJ400
         LI,R4    X'B'              LOAD NC DTYP
         LH,V0    3,R5              LOAD,CHECK BSIZ                     ADJ381
         CI,V0    CGMXB                                                 ADJ382
         BG       ADJ38             BSIZ > MAX BSIZ ALLOWED
         LW,V1    V0                DSIZ = BSIZ *2-1                    ADJ401
         AW,V1    V0                                                    ADJ402
         AI,V1    -1                                                    ADJ403
         CI,D0    CDZF              CHECK FOR ZERO FILL CHAR.           ADJ404
         BCR,CB   ADJ41             NO ZERO FILL CHAR                   ADJ405
         AI,V1    -1                REDUCE DSIZ FOR ZERO FILL           ADJ406
ADJ41    RES      0                                                     ADJ410
         LH,D3    4,R2              LOAD,CHECK DECP                     ADJ411
         BCR,CZ   ADJ45-1           DECP = 0, INTEGER                   ADJ412
         BCS,CL   ADJ43             DECP < 0, TRAIL P'S                 ADJ413
         SW,V1    D3                DSIZ = DSIZ - DECP                  ADJ414
         BCS,CP   ADJ42             DSIZ > 0                            ADJ415
* S*****FRACTION USED AS SUBSCRIPT**                                    ADJ416
         LI,R1    XSS+4             LOAD DIAG CODE                      ADJ417
         B        ADJ38+1
ADJ42    RES      0                                                     ADJ420
* W*****NON-INTEGER USED AS SUBSCRIPT**                                 ADJ421
         LI,R1    XSW-3             LOAD DIAG CODE                      ADJ422
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ423
         B        ADJ44                                                 ADJ424
ADJ43    RES      0                                                     ADJ430
         SW,V1    D3                DSIZ = DSIZ-DECP                    ADJ431
         CI,D3    -CGMXS            CHECK IF SIGNIFICANCE LOST          ADJ432
         BCS,CG   ADJ44             NO. SOME SIGNIFICANCE RETAINED      ADJ433
* S*****SIGNIFICANCE LOST WHEN ALIGNED***                               ADJ434
         LI,R1    XSS+5             LOAD DIAG CODE                      ADJ435
         B        ADJ38+1
ADJ44    RES      0                                                     ADJ440
         AI,D0    -CDDNI            ADJUST DTYP FOR NON-INTEGER         ADJ441
         SLS,D3   8                 POSITION,ATTACH SHIFT COUNT         ADJ442
         AW,D3    V0                                                    ADJ443
ADJ45    RES      0                                                     ADJ450
         CI,V1    CGMXS             CHECK DIGIT SIZE                    ADJ451
         BCR,CG   ADJ46             </= EFFECTIVE DIGIT SIZE            ADJ452
* W*****INEFFECTIVE DIGITS TRUNCATED**                                  ADJ453
         LI,R1    XSW-4             LOAD DIAG CODE                      ADJ453
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ454
* FORM ND/NC SUBSCRIPT ENTRY                                            ADJ46
ADJ46    RES      0                                                     ADJ460
         AI,R3    1                 UPDATE STKTOP
         STH,D3   0,R3              STORE SHIFT,BSIZE
* BINARY                                                                ADJ50
ADJ50    RES      0                                                     ADJ500
         LW,V0    JSUBF-1,R7        LOAD SUBF(I)                        ADJ513
         AW,V2    R4                APPEND DTYP
         SLS,V2   4                 POSITION DTYP
         MTH,12   JTSH              UPDATE TYPE CONTROL SHIFT           ADJ541
         RCRF     R5                READ NEXT CLUSTER                   ADJ542
         LH,V1    0,R5              LOAD,CHECK OPT                      ADJ543
         AI,V1    X'2E00'           -CBXDC+X'100'
         BEZ      ADJ55             INDEX INCREMENT(IXI)
         AI,V1    -X'100'                                               ADJ546
         BCS,CZ   ADJ57             NOT INDEX DECREMENT(IXD)            ADJ547
         LCW,V0   V0                COMPLEMENT SUBF(I)                  ADJ548
* INDEX INCREMENT/DECREMENT                                             ADJ55
ADJ55    RES      0                                                     ADJ550
         LH,D1    1,R5              LOAD IXI/IXD VALUE (INVF)           ADJ551
         LH,D2    1,R2                                                  ADJ552
         STH,D2   D1                                                    ADJ553
         MW,D1    V0                INVS(I) = INVF*(+/-SUBF(I))         ADJ554
         CI,R4    X'C'              CHECK CLASS
         BE       ADJ18             CLASS INDEX
* W*****SUBSCRIPT INCREMENT/DECREMENT USED***                           ADJ56
         LI,R1    XSW-5             LOAD DIAG CODE                      ADJ561
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ562
         SW,D1    JSUBF-1,R7        INVS(I) = INVS(I)-SUBF(I)           ADJ563
         RCRF     R5                READ NEXT CLUSTER                   ADJ564
         B        ADJ58                                                 ADJ565
ADJ57    RES      0                                                     ADJ570
         CI,R4    X'C'              CHECK CLASS
         BE       ADJ19+1           CLASS INDEX
         LCW,D1   V0                INVS(I) = -SUBF(I)                  ADJ573
ADJ58    RES      0                                                     ADJ580
         LB,V0    JTDBN,R7          CHECK TDB(I)                        ADJ581
         BCR,CZ   ADJ19             TDB(I) = 0, NON-TABLE ITEM          ADJ582
*  THE FOLLOWING CODE WAS INSERTED FOR SIDR-2942  11-12-70              COBOL41P
*  IT WILL GIVE DIAG 172 ONLY WHEN A TABLE WAS DECSRIBED AS BEING       COBOL41P
*  INDEXED AND SUBSCRIPTING IS BEING USED                               COBOL41P
         STW,R6    SAV6      SAVE  R6                                   COBOL41P
         LB,R1     JTDB          TDB NO.                                COBOL41P
         LH,R6     *PDBZ+4,R1        TDB  LOCATION                      COBOL41P
         SLS,R6    -2     BA  DISPL TO WA                               COBOL41P
         LW,R1     *PDBZ+3,R6                                           COBOL41P
         LI,R6     1                                                    COBOL41P
         LH,R1     R1,R6         INDEX  DISPL                           COBOL41P
         LW,R6     SAV6     LOAD R6                                     COBOL41P
         CI,R1     X'0000'        NO DISPL                              COBOL41P
         BE        ADJ19   NOT AN INDEXED TABLE ITEM                    COBOL41P
* W*****SUBSCRIPTED TABLE ITEM******                                    ADJ583
         LI,R1    XSW-6             LOAD DIAG CODE                      ADJ584
         BAL,L1   DIAG              TO WRITE DMF CLUSTER                ADJ585
         B        ADJ19                                                 ADJ586
ADJ59    RES      0                                                     ADJ590
* W*****FLOATING POINT SUBSCRIPT,INTEGER USED***                        ADJ5900
         DX       XSW-7,ADJ50       WRITE DMF CLUSTER
* INDEX
ADJ60    RES      0                                                     ADJ600
         STH,D3   D3                POSITION,CHECK TDB                  ADJ601
         LB,D3    D3                                                    ADJ602
         CB,D3    JTDBN,R7                                              ADJ603
         BE       ADJ50             TDB = TDB(I) - PROPERLY INDEXED
* W*****ILLEGAL INDEX NAME/DATA USAGE***                                ADJ605
         DX       XSW-8,ADJ50       WRITE DMF CLUSTER
ADJ65    STW,R7   VRSAV
         LW,R7    VPCNT
         MTW,0    VPDSP-2,R7
         BEZ      ADJ66             NO VAR REC
         AW,R7    R7
         AI,R7    1
         STH,V0   VPDSP-2,R7        UPDATE DISP IN VPDSP
ADJ66    LW,R7    VRSAV
         B        *L1
* PROCESS VARIABLE RECORD PARAMETERS
ADV00    LCI      8
         STM,R1   VRSAV
         SLS,R4   -1
         LH,R1    0,R4
         AND,R1   L(X'F0')
         CI,R1    X'80'
         BNE      ADV15             NOT DATA DEF
         SLS,R4   1
         BAL,V0   ADV20
ADV04    LW,R1    VPCNT
         BLEZ     ADV011            NOT VAR REC
         LW,R6    VPCL+1
         LW,R7    VPCL+2
         SLD,R6   16
         LI,R5    0
ADV01    CW,R6    VPDSP,R5
         BE       ADV02
         AI,R5    2
         CW,R5    VPCNT
         BL       ADV01
ADV011   MTB,1    VPCL              NOT VAR REC
         B        ADV14
ADV02    LW,R2    VPDSP+1,R5
         LW,R3    0,R2
ADV03    LB,R6    VPCL
         LH,R5    VPCL+1
         OR,R5    R6                VAR REC DISP
         STH,R5   VPCL+1
         AI,R6    1
         MTB,1    VPCL
         LI,R5    HA(VPCL)
         AW,R5    R6
         AW,R5    R5
ADV031   STH,R3   VPCL,R6           SAVE REF NO
         LH,R7    VPCL,R6
         LH,R3    R3
         AI,R6    -1
         MTB,2    VPCL
         AI,R7    0
         BLZ      ADV07
         LW,R1    VREFN
         CI,R1    199
         BGE      ADV07             VREFT FULL
         STH,R7   VREFT,R1          SAVE REF NO
ADV05    AI,R1    -1
         BLZ      ADV06
         CH,R7    VREFT,R1
         BNE      ADV05
         LI,R1    4
         STH,R1   VPCL,R6           SAVE LNTH COUNT
         B        ADV14
ADV06    MTW,1    VREFN             UPDATE COUNT
         MTW,1    NSREF
ADV07    SLS,R3   -2
         AI,R3    -1
         AW,R2    R3
         LB,R4    VPCL              UPDATE CLUSTER LNTH COUNT
         SLS,R3   3
         AW,R4    R3
         SLS,R3   1
         LW,R7    R3
         AI,R7    4
         MTW,0    NSREF             PARAM LENGTH
         BEZ      ADV08
         AI,R7    X'8000'           SET REF NO SAVED FLAG
         MTW,-1   NSREF
ADV08    STH,R7   VPCL,R6
         SLS,R3   -4
         STB,R4   VPCL              ADJUST A OF CLUSTER
         AI,R5    2
ADV10    LW,R6    0,R2              PARAM
         BGEZ     ADV11
         LCW,R6   R6                FOR ADDRESS
         LI,R7    X'8000'
         B        ADV12
ADV11    LI,R7    0                 FOR LENGTH
ADV12    STH,R6   R7
         LB,R4    R6                GET CLASS
         SLS,R4   8
         OR,R7    R4                SLACK AND ALLIGNMENT
         LH,R6    R6                TDB NUMBER
         AND,R6   L(X'FF')
         LH,R6    *PDBZ+4,R6
         SLS,R6   -2
         AW,R6    PDBZ+3            WA(TDB)
         LW,R4    2,R6
         AND,R4   L(X'F0000')       GET CLASS
         SLS,R4   -16
         OR,R7    R4
         SLS,R5   -1
         STH,R7   0,R5              STORE D
         AI,R5    1
         SLS,R7   -16
         STH,R7   0,R5              STORE B AND C
         AI,R5    1
         AW,R5    R5                TO BYTE
         LW,R4    R6
         SLS,R4   2
         LI,R1    10
         STB,R1   R5
         MBS,R4   14                BASE - DECP
         LI,R1    2
         STB,R1   R5
         MBS,R4   -4                MAX OCCURS NUMBER
         AI,R2    -1
         BDR,R3   ADV10             NEXT
ADV14    LI,R5    BA(VPCL)
         STW,R5   VRSAV+3
ADV15    LI,R5    0
         STW,R5   ADVMF
         LCI      8
         LM,R1    VRSAV
         B        *L1
ADV20    LB,R6    0,R4
         LI,R5    HA(VPCL)          MOVE IN DATA CLUSTER
         STB,R6   R5
         AW,R5    R5
         MBS,R4   0
         MTW,-1   ADVMF
         BGZ      *V0               C2 - READ, WRITE
         LH,R4    VPCL+1
         AI,R6    -1
         STH,R4   VPCL,R6           SAVE INDEX INFORMATION
         SLS,R6   8
         AI,R6    X'8000'
         STH,R6   VPCL+1
         B        *V0
ADL00    LCI      8                 LOAD CLUSTER
         STM,R1   VRSAV
         BAL,V0   ADV20
         MTW,0    ADVMF
         BEZ      ADV011            SEARCH
         B        ADV04
ADS00    LH,R4    1,R2              SAVE VAR PARAM - WRITE
         BNEZ     ADS01
         STW,R4   VWPM
         B        *L1
ADS01    STW,R5   VRSAV             SAVE R5
         SLS,R4   -1
         AW,R4    R2
         LH,R5    0,R4              PARAM LNTH
         SLS,R5   24
         AI,R5    BA(VWPM)
         SLS,R4   1
         MBS,R4   0
         LW,R5    VRSAV
         B        *L1
ADW00    LCI      8                 C2 - READ WRITE
         STM,R1   VRSAV
         MTW,2    ADVMF
         BAL,V0   ADV20
         LI,R3    0
         LI,R2    1
         STB,R3   VPCL+4,R2         CLEAR DISP BYTE
         MTB,1    VPCL
         LI,R5    BA(VPCL)
         LW,R3    VWPM              PARAM COUNT
         BEZ      ADV14+1
         STB,R6   VPCL+4,R2
         LI,R2    WA(VWPM)
         AI,R6    1
         AW,R5    R6                BYTE DISP
         AW,R5    R6
         B        ADV031
AVI00    STW,L1   TMPV0             VAR REC INIT
         LI,L1    0
         STW,L1   VPCNT
         STW,L1   VWPM
         LI,L1    WA(VPAM)
         STW,L1   VPAA
         B        *TMPV0
         PAGE
* SAVE REFERENCES                  "SREF"                               ADM
ADM00    RES      0                                                     ADM00
*                        R2 = 0 - DATA ITEM NOT IN OPSTK                ADM0001
*                           NOT= 0(=NLOC) - DATA ITEM IN OPSTK          ADM0002
*                        R3 = HA(STKTOP)                                ADM0003
*                        R4 = HA(CLOC)                                  ADM0004
*                        R5 = HA(CLOC)+1                                ADM0005
*                        L1 = LINK REGISTER                             ADM0009
         CI,R2    0                 CHECK NLOC                          ADM001
         BCS,CE   *L1               NLOC NOT= 0, DATA ITEM IN OPSTK     ADM002
ADM02    RES      0                                                     ADM020
         LW,R5    R3                SAVE STKTOP(=HA(CLOC)-1)            ADM021
         LW,R2    R4                SET MBS R = BA(CLOC)                ADM022
         AW,R2    R4                                                    ADM023
         LB,R4    0,R2              CLNG TO MBS RU1                     ADM024
         STB,R4   R3                                                    ADM025
         AI,R3    1                 HA(CLOC)-1 TO HA(CLOC)              ADM027
         LW,R4    R3                SAVE HA(CLOC)                       ADM026
         AW,R3    R3                CLNG,CLOC TO BA                     ADM028
         MBS,R2   0                 DATA ITEM TO OPSTK                  ADM031
         SLS,R3   -1                STKTOP TO HA                        ADM032
         B        *JRDF             READ NEXT CLUSTER                   ADM034
*                        R2 = HA(NLOC)                                  ADM0402
*                        R3 = HA(STKTOP),UPDATED                        ADM0403
*                        R4 = HA(CLOC)                                  ADM0404
*                        R5 = HA(CLOC)-1                                ADM0405
* SKIP SUBSCRIPTS/INDICES          "SKIP"                               ADN
*    *FIRST SUBSCRIPT/INDEX CLUSTER READ                                ADN0
*                        R1 = DIAG ERROR CODE                           ADN0 1
*                        R7 = REF,STMT OPTIONS(PRESERVED)               ADN0 7
*                        LO = RETURN LINK                               ADN0 8
ADN00    RES      0                                                     ADN00
         BAL,L1   DIAG              WRITE DMF CLUSTER                   ADN01
ADN02    RES      0                                                     ADN20
         LI,R1    CBSUB             CHECK FOR SUBS/INDX                 ADN21
         AND,R1   R7                                                    ADN22
         BCR,CA   *L0               NO SUBS/INDX                        ADN23
         EOR,R7   R1                CLEAR NSUB                          ADN234
         SLS,R1   -5                SET SUBS/INDX COUNT (NSUB)          ADN24
ADN04    RES      0                                                     ADN40
         RCRF                       READ NEXT CLUSTER                   ADN41
         AI,R2    1                 SET HA(NLOC)+1                      ADN414
         LH,L1    0,R2              CHECK FOR INDEX INCREMENT           ADN42
         AI,L1    CBXIM                                                 ADN43
         BCR,CZ   ADN04             INCREMENT                           ADN44
         AI,L1    -CBXDM            CHECK FOR INDEX DECREMENT           ADN45
         BCR,CZ   ADN04             DECREMENT                           ADN46
         BDR,R1   ADN04             NSUB = NSUB-1                       ADN47
ADN06    RES      0                                                     ADN60
         BDR,R2   *L0               RETURN                              ADN71
*                        R2 = HA(NLOC)                                  ADN712
*
* TRUNCATION CHECK
*                        V0 = DECPR
*                        V1 = DSIZR
*                        V2 = SIZE FLAG(X'1----')
ADT00    RES      0
         CI,V2    CITC              CHECK TRUNCATION FLAG
         BAZ      *L1               DOWN. RETURN
* UP. CHECK TRUNCATION
         LW,D1    JDSIZ             COMPUTE DSIZS-DECPS+DECP
         SW,D1    JDECP
         AW,D1    V0
         CW,V0    JDECP             COMPARE DECP,DECPS
         BGE      ADT03             DECP >/= DECPS, NO RIGHT TRUNCATION
         SW,D1    V1                CHECK DSIZS-DECPS-(DSIZ-DECP)
         BLE      ADT02             </= 0, NO LEFT TRUNCATION
* W*****INTEGER AND FRACTIONAL DIGITS TRUNCATED***
         LI,R1    XTW+2             LOAD DIAG CODE
ADT01    RES      0
         CI,R6    1                 CHECK TYPE,CLASS
         BG       DIAG              =NUMERIC
         BANZ     ADT02             = AN/ANE
         CI,R6    6                 CHECK CLASS
         BANZ     DIAG              = ANJR/ANEJR
* W*****RIGHTMOST AND/OR FRACTIONAL DIGITS TRUNCATED***
ADT02    RES      0
         DX       XTW,,0            WRITE DMF CLUSTER
ADT03    RES      0
         SW,D1    V1                CHECK DSIZS-DECPS-(DSIZ-DECP)
         BLE      *L1               </= 0, NO LEFT TRUNCATION
* W*****LEFTMOST DIGITS/CHAR. TRUNCATED****
         LI,R1    XTW+1             LOAD DIAG CODE
         B        ADT01
*
NSUB     DATA     0                 NO. OF SUBSCRIPT/INDEX
REMDR    DATA     0
DIVDF    DATA     0
LDVDP    DATA     0
NSREF    DATA     0                 SAVE REF NO FLAG
TMPV0    RES      1
VRSAV    RES      8
VPAA     DATA     VPAM
VPCNT    DATA     0
CORRF    DATA     0                 CORRESPONDING FLAG
ECFRF    DATA     0
ADVMF    DATA     0
VREFN    DATA     0
VWPM     RES      16
VPCL     RES      72
VREFT    RES      100               REF NO. TABLE
VPDSP    RES      200                                                   COBOL41P
VPAM     RES      800               VAR REC PARAM BUFFER
K2FF     DATA     X'FF00'                                               ADI
K33F     DATA     X'3F'             NE DIGIT SIZE MASK                  ADI523
SAV6     DATA     0   SAVE  R6                                          COBOL41P
         BOUND     8                                                    COBOL41P
SAV67    RES       2                                                    COBOL41P
K20F     EQU      JAKON+2           CLASS
K2F00F   EQU      JAKON+3           TYPE,NDIM
K2FFF    EQU      JAKON+4
K303     EQU      JAKON+5
K3FF     EQU      JAKON+6           BYTE MASK
JTDB     EQU      JADAT+3           TDB/DDB NO.,0
JDECP    EQU      JADAT+4
JDSIZ    EQU      JADAT+5
JNDIM    EQU      JADAT+64          NO OF DIM.
JTDBN    EQU      JADAT+65          TDB NO.
JNSUBX   EQU      JADAT+66          REMAINING SUBS/IND.
JSUBF    EQU      JADAT+67          SUBSCRIPT FACTORS
JCLNG    EQU      JADAT+X'46'       CLNG
JINVS    EQU      JADAT+73          INVARIANT SUBSCRIPTS
JTSH     EQU      JADAT+74          TABLE
JADDR    EQU      JADAT+75          ADDR. RES.
ADISAV   EQU      JASAV+10          L0-D3
ADJSAV   EQU      JASAV+16          R4-L1
         END
