         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    'PHASE 2.1 CONTROL'
COB21    BAL,R11  INIT              INITIALIZE
M1       BAL,R11  RDEDF             READ EDF CLUSTER
         BLZ      ENDPH21           END OF ENCODED DATA FILE
         AI,R2    1
         LB,R3    0,R2              GET CLUSTER CONTROL BYTE
M2       CI,R3    X'37'
         BGE      BADCB             UNDEFINED CONTROL BYTE VALUE
         B        CBVECTOR,R3
CBVECTOR B        LINEUP            00 LINE NUMBER
         B        BADCB             01 UNDEFINED
         B        BADCB             02 UNDEFINED
         B        BADCB             03 UNDEFINED
         B        BADCB             04 UNDEFINED
         B        BADCB             05 UNDEFINED
         B        BADCB             06 UNDEFINED
         B        BADCB             07 UNDEFINED
         B        SH                08 FILE SECTION HEADER
         B        SH                09 WORKING-STORAGE SECTION HEADER
         B        SH                0A LINKAGE SECTION HEADER
         B        SH                0B COMMON-STORAGE SECTION HEADER
         B        RS                0C REPORT SECTION HEADER
         B        BADCB             0D UNDEFINED
         B        BADCB             0E UNDEFINED
         B        BADCB             0F UNDEFINED
         B        DB                10 DESCRIPTION BLOCK
         B        BADCB             11 UNDEFINED
         B        BADCB             12 UNDEFINED
         B        BADCB             13 UNDEFINED
         B        BADCB             14 UNDEFINED
         B        BADCB             15 UNDEFINED
         B        BADCB             16 UNDEFINED
         B        BADCB             17 UNDEFINED
         B        BADCB             18 UNDEFINED
         B        BADCB             19 UNDEFINED
         B        BADCB             1A UNDEFINED
         B        BADCB             1B UNDEFINED
         B        BADCB             1C UNDEFINED
         B        BADCB             1D UNDEFINED
         B        BADCB             1E UNDEFINED
         B        BADCB             1F UNDEFINED
         B        MN                20 MNEMONIC NAME
         B        DE                21 DATA ENTRY
         B        SPEC              22 SPECIFICATIONS
         B        FIL               23 FILLER
         B        OCC               24 OCCURS
         B        OCT               25 OCCURS TO
         B        ODO               26 OCCURS DEPENDING ON
         B        AKY               27 ASCENDING KEY
         B        DKY               28 DESCENDING KEY
         B        IDX               29 INDEXED BY
         B        PIC               2A PICTURE
         B        RED               2B REDEFINES
         B        RNN               2C REDEFINES WITHOUT DATA NAME
         B        REN               2D RENAMES
         B        VAL               2E VALUE
         B        GISUM             2F GROUP INDICATE/SUM
         B        RSPEC             30 REPORT SPECIFICATIONS
         B        BEGLI             31 BEGINNING OF LINE IMAGE
         B        ENDLI             32 END OF LINE IMAGE
         B        RPTDE             33 REPORT DATA ENTRY
         B        RPTFIL            34 REPORT FILLER (FOR SUM)
         B        ERE               35 END OF REPORT ENTRY
         B        NRE               36 NAMELESS REPORT ENTRY
BADCB    RES      0
         LI,R1    504
         BAL,R11  DIAG              COMPILER ERROR 04
         B        M1                IF CONTINUE
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         TITLE    'PHASE 2.1 EXTERNAL REFERENCES AND DEFINITIONS'
         PAGE
         REF      CARDNO            CARD NUMBER
         REF      DIAG              DIAGNOSTIC MESSAGE OUTPUT ROUTINE
         REF      M:LO              SYSTEM DCB
         REF      PDBCC             COMPILER CONTROL WORD OF PDB
         REF      PDBL              L FIELD OF PDB
         REF      PDBM              M FIELD OF PDB
         REF      PDBN              N FIELD OF PDB (TTL DB LNGTH IN BYT)
         REF      PDBO              O FIELD OF PDB (LAST SEG# + LENGTH)
         REF      PDBP              P FIELD OF PDB (ABORT BIT)
         REF      PDBQ              Q FIELD OF PDB (TTL WD LNGTH DSC BL)
         REF      PDBQB             NO. OF BYTES GENERATED UNDER BASE 1
         REF      PDBSA             NO. OF BYTES GENERATED UNDER BASE 4
         REF      PDBUB             NO. OF BYTES GENERATED UNDER BASE 9
         REF      PDBVA             NO. OF BYTES GENERATED UNDER BASE 10
         REF      PDBZ              DYNAMIC STORAGE TABLE ORIGINS
         REF      PDBMSL             MAXIMUM SEGMENT LENGTH (WORDS)
         REF      PH21E             PHASE 2.1 EXIT
         REF      RDEDF             EDF CLUSTER INPUT ROUTINE
         REF      RDIVF             IVF CLUSTER INPUT ROUTINE
         REF      VPROC             VALUE PROCESSING ROUTINE
         REF      WRDDD             DICTIONARY OUTPUT ROUTINE
         REF      WRPOF
         REF      WRXRF             CROSS REF. CLUSTER OUTPUT ROUTINE
         REF      WRMDF
         REF      PDBTDB                                                COBOL21
         REF      PDBDBG                                                COBOL21
         DEF      BASE4DSP
         DEF      COB21             PHASE 2.1 ENTRY POINT
         DEF      DLPNTR
         DEF      WABEG             WORK AREA BEGINNING AND ENDING LIMIT
         DEF      WAEND              BASE1DSP THRU SHPREV
         TITLE    'PHASE 2.1 INITIALIZATION'
         PAGE
INIT     LW,R1    PDBZ+5            HIGHEST AVAILABLE CORE ADDRESS
         LI,R7    1
         AI,R1    -100              COMPUTE ORIGIN OF DBINDX
         STW,R1   PDBZ+4
         LH,R3    PDBL,R7                                               COBOL21
         STB,R3   PDBZ+4                                                COBOL21
         SLS,R1   2                 COMPUTE ORIGIN (IN BYTES) OF SEG. 0
         MI,R3    80                MAX DDB IN BYTES                    COBOL21
         SW,R1    R3                RESERVE SPACE FOR DDB               COBOL21
         LW,R3    PDBTDB            NO OF TDB'S                         COBOL21
         MI,R3    32                MAX TDB SIZE IN BYTES               COBOL21
         SW,R1    R3                RESERVE SPACE FOR TDB               COBOL21
         AND,R1   L(X'FFFFFFFC')    WORD ADJUST THE BYTE ORIGIN
         STW,R1   PDBZ+3
         STW,R1   DBPNTR
         SH,R1    PDBL              COMPUTE ORIGIN (IN BYTES) OF DINDEX
         AND,R1   L(X'FFFFFFFC')    WORD ADJUST THE BYTE ORIGIN
         AI,R1    -4
         STW,R1   PDBZ+2
         LW,R1    PDBZ              GET LOWEST CORE WORK AREA ADDRESS
         STW,R1   DLPNTR            INITIALIZE DICT. POINTER
         LI,R1    100
         LI,R2    -1                SET DBINDX TO ALL BITS
         STW,R2   *PDBZ+4,R1
         BDR,R1   %-1
         STW,R2   *PDBZ+4
         LW,R1    PDBZ+4
         AND,R1   L(X'FFFFFF')
         AI,R1    -1                SET REMAINDER OF CORE WORK AREA
         SW,R1    PDBZ               TO ZERO
         LI,R2    0
         STW,R2   *PDBZ,R1
         BDR,R1   %-1
         STW,R2   *PDBZ
         LI,R1    99                CLEAR PDL
         STW,R2   *PDLX,R1
         BDR,R1   %-1
         STW,R2   *PDLX
         LI,R1    20                CLEAR KEYTAB
         STW,R2   KEYTAB-1,R1
         BDR,R1   %-1
         LI,R2    4                 OUTPUT TERMINAL SEGMENT ID
         LI,R4    BA(SEGID)          FOR PHASE 3 REVERSED DICT. INPUT
         AWM,R2   DBPNTR            MAKE 1ST DB ADDR. NON-ZERO
         STW,R11  INITEXIT
         BAL,R11  WRDDD
         LI,R4    1
         AND,R4   PDBCC                                                 COBOL21
         BEZ      WFIGCON
         LI,R11   X'7F'                                                 COBOL21
         STB,R11  BASE4LIT+2,R4
         LI,R4    2                                                     COBOL21
         STB,R11  FCCHAR,R4                                             COBOL21
WFIGCON  EQU      %
         DEF      FCCHAR                                                COBOL21
         LI,R4    BA(BASE4LIT)      OUTPUT PREASSIGNED LITERALS
         BAL,R11  WRPOF
         B        *INITEXIT
INITEXIT RES      1
         TITLE    'LINE NUMBER CLUSTER PROCESSOR'
         PAGE
LINEUP   AI,R2    1                 SAVE CURRENT LINE NUMBER AND SUB
         LI,R3    BA(CARDNO)         IN CARDNO  (PDBX)
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         B        M1
         TITLE    'SECTION HEADER CLUSTER PROCESSOR'
         PAGE
CS       LW,R4    L77TVI            RECOVER INST                        COBOL21
         STW,R4   L77TV                                                 COBOL21
LS       RES      0                                                     COBOL21
WS       STW,R2   FSTWSCS           WORKING-STORAGE SECTION
         LI,R4    0
         STW,R4   L77DUP
         STW,R4   L1DUP                                                 COBOL21
         LW,R4    SHFLG
         STW,R4   SHPREV            SAVE PREVIOUS SEC. HDR.
         STB,R3   SHFLG             STORE NEW SEC. HDR.
         LW,R3    R6
         B        M2
FS       STB,R3   SHPREV            FILE SECTION
         B        %-4
RS       BAL,R11  INMDF
         LI,R11   4
         STW,R11  ADDDL
RS1      BAL,R11  RDEDF             REPORT SECTION
         BLZ      ENDPH21
         AI,R2    1
         LB,R3    0,R2
         BEZ      RS1
         LI,R4    X'C'
         STW,R2   FSTWSCS
         LW,R5    SHFLG
         STW,R5   SHPREV
         STB,R4   SHFLG
         B        M2
SH       STB,R3   SHSAVE
         LI,R11   4
         STW,R11  ADDDL
         BAL,R11  INMDF
SH1      BAL,R11  RDEDF             LOOK AHEAD TO SEE IF CURRENT SECTION
         BLZ      ENDPH21            IS VACUOUS
         AI,R2    1
         LB,R6    0,R2
         BEZ      SH1
         CI,R6    X'B'
         BG       SH2
         STB,R6   SHSAVE            IT IS - LOOK FOR MORE VACUAE
         XW,R6     FILTYN
         B        SH1
SH2      LB,R3    SHSAVE
         B        SH3-8,R3
SH3      B        FS
         B        WS
         B        LS
         B        CS
INMDF    XW,R3    FILTYN
         LW,R4    NUL01
         BEZ      *R11              NULL SECTION
         STW,R3   FILTYP
         MTW,-1   NUL01
         MTW,1    SECNT
         LI,R3    1
         STW,R3   FIR01
         B        *R11
         TITLE    'MNEMONIC-NAME CLUSTER PROCESSOR'
         PAGE
MN       LI,R3    X'2006'           DMAP AND/OR XREF
         AND,R3   PDBCC              BEEN REQUESTED
         BEZ      MN0                NO
         LW,R12   L(X'05010000')     YES - CONSTRUCT AND OUTPUT A
         AI,R2    3                  DATA DEFINITION CLUSTER TO
         LI,R3    50                 THE CROSS REFERENCE FILE
         LI,R4    6
         STB,R4   R3
         MBS,R2   0
         LI,R4    48
         BAL,R11  WRXRF
         AI,R2    -9
MN0      SLS,R2   -1
         AI,R2    2
         LH,R3    0,R2              GET R-NUMBER
         LW,R1    DXORG
         AW,R1    R3                EXAMINE DINDEX(R#)
         LI,R4    3
         STB,R4   R1                IS ENTRY OCCUPIED?
         CBS,0    16
         BE       MN1
         AI,R2    2                 YES - ERROR - DUPLICATE MNEM NAMES
         LH,R3    0,R2
         STW,R3   CARDNO
         AI,R2    -1
         LH,R3    0,R2
         STH,R3   CARDNO
         LI,R1    65
         BAL,R11  DIAG              DUPLICATE MNEMONIC NAMES
         B        MN3
MN1      LW,R3    SEGNUM            MOVE CURRENT RELATIVE DICT. ADDRESS
         SLS,R3   14                 AND CURRENT SEG # TO DINDEX(R#)
         LW,R5    R1
         LW,R4    DLPNTR
         SW,R4    DLORG
         AW,R3    R4
         LI,R4    13
         AI,R5    -3
         OR,R5    L(X'3000000')
         MBS,R4   0
         LW,R4    DXORG
         SLS,R4   -2
         SW,R4    DLPNTR
         CI,R4    4                 ROOM IN DLAREA FOR NEW ENTRY?
         BGE      MN2
         BAL,R11  OUTSEG            NO - OUTPUT CURRENT SEGMENT
MN2      LW,R5    L(X'4000000')     CONSTRUCT MNEM NAME DICT. ENTRY
         LI,R7    2
         STW,R5   *DLPNTR           B=0 FOR VALID MNEM NAME ENTRY A=4
         AI,R2    1
         LH,R5    0,R2
         STH,R5   *DLPNTR,R7        C=SOURCE LINE NUMBER
         AI,R2    1
         LI,R7    3
         LH,R5    0,R2
         STH,R5   *DLPNTR,R7        D=SOURCE LINE SUB-NUMBER
         LI,R7    6
         STH,R3   *DLPNTR,R7        G=R#
         AI,R2    -3
         LI,R7    7
         LH,R5    0,R2
         LI,R3    X'FFF'            H=TYPE    0 FOR MNEM NAME
         AND,R3   R5                I=MNEM NAME CATEGORY
         STH,R3   *DLPNTR,R7        J=HARDWARE IDENTIFICATION
         MTW,4    DLPNTR            BUMP DICT. POINTER
         LW,R4    DLPNTR
         SW,R4    DLORG
         LI,R7    -2                E=0
         STW,R4   *DLPNTR,R7        F=END OF RANGE
MN3      BAL,R11  RDEDF             READ NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         BEZ      MN3               IF LINE NO. CLUSTER, DISCARD
         CI,R3    X'20'             IS CLUSTER MNEM NAME?
         BE       MN                YES
         LW,R4    SEGNUM
         LW,R5    SEGLNGTH          STORE SEG#IN MB FIELD
         SCS,R5   14                 AND SEG LENGTH IN MC FIELD OF PDB
         SLD,R4   18
         STW,R5   PDBM
         BAL,R11  OUTSEG
         B        M2
OUTSEG   STW,R11  OSEXIT
         LCI      5
         STM,R1   OSTEMP
         LB,R2    *DLPNTR
         AW,R2    DLPNTR
         SW,R2    DLORG
         STW,R2   SEGLNGTH
         LW,R1    R2
         SLS,R2   2
         LW,R4    DLORG
         SLS,R4   2                 WRITE DICT. WORK AREA
         LCI      7
         STM,R1   DDREG             SAVE REGISTERS
         LI,R5    50
         STW,R5   PNVLVL
         SLS,R4   -2
         LW,R1    3,R4                                                  COBOL21
         AND,R1   L(X'F000')        H FIELD                             COBOL21
         BEZ      DDLNK8
         CI,R1    X'5000'                                               COBOL21
         BL       DDLNK8
         SLS,R4   2
         LB,R5    2,R4              LEVEL NUMBER
         CI,R1    X'8000'                                               COBOL21
         BLE      OUTSEG3           IN FILE SECTION                     COBOL21
         SLS,R4   -2                                                    COBOL21
         LW,R1    5,R4              SIZE                                COBOL21
         AND,R1   L(X'FFFF')                                            COBOL21
         CI,R5    1                                                     COBOL21
         BE       OUTSEG1           01 LEVEL                            COBOL21
         CI,R5    X'81'                                                 COBOL21
         BE       OUTSEG0           01 REDEFINES                        COBOL21
         CI,R5    X'4D'                                                 COBOL21
         BNE      OUTSEG2           NOT 77 LEVEL                        COBOL21
         SLS,R2   -2                WORD COUNT                          COBOL21
OUTS77   STW,R1   REDSZ             SAVE 77 SIZE                        COBOL21
OUTS78   LB,R1    *R4               LENGTH OF ENTRY                     COBOL21
         SW,R2    R1                                                    COBOL21
         BLEZ     OUTSEG2           DONE                                COBOL21
         AW,R4    R1                TO NEXT ENTRY                       COBOL21
         LW,R1    5,R4                                                  COBOL21
         AND,R1   L(X'FFFF')        SIZE                                COBOL21
         AI,R4    2                                                     COBOL21
         LB,R3    *R4               LEVEL NUMBER                        COBOL21
         AI,R4    -2                                                    COBOL21
         CI,R3    X'80'                                                 COBOL21
         BAZ      OUTS77            NOT REDEFINES                       COBOL21
         CW,R1    REDSZ                                                 COBOL21
         BE       OUTS78            SAME SIZE                           COBOL21
         BAL,R11  REDIAG                                                COBOL21
         STW,R3   CARDNO            RESTORE CARD NUMBER                 COBOL21
         B        OUTS78                                                COBOL21
REDIAG   LW,R3    1,R4              CARD NUMBER                         COBOL21
         XW,R3    CARDNO                                                COBOL21
         LI,R1    103               REDEFINES SIZE ERROR                COBOL21
         B        DIAG                                                  COBOL21
OUTSEG0  CW,R1    REDSZ                                                 COBOL21
         BE       OUTSEG2           SAME SIZE                           COBOL21
         BAL,R11  REDIAG                                                COBOL21
         STW,R3   CARDNO            RESTORE CARD NUMBER                 COBOL21
         B        OUTSEG2                                               COBOL21
OUTSEG1  STW,R1   REDSZ             SAVE 01 SIZE                        COBOL21
OUTSEG2  LCI      4                 RECOVER R1 - R4                     COBOL21
         LM,R1    DDREG                                                 COBOL21
OUTSEG3  AND,R5   L(X'7F')          REMOVE REDEFINES BIT                COBOL21
         CI,R5    1
         BE       DDLNK05
         CI,R5    77
         BNE      DDLNK8
DDLNK0   BAL,R7   DDLNK02           77 ITEMS
         BAL,R7   DDLNK04
         AW,R4    R3
         AI,R2    0
         BLEZ     DDLNK01           END OF SEGMENT
         STB,R3   0,R4              SET BYTE LENGTH
         AI,R4    1
         B        DDLNK0
DDLNK01  STB,R2   0,R4
         B        DDLNK8
DDLNK02  LB,R3    0,R4
         SLS,R3   2                 BYTE LENGTH
         SW,R2    R3
         AI,R3    -1
         B        *R7
DDLNK04  SLS,R4   -2                CLEAR BITS 0, 1 OF K
         LW,R5    3,R4
         AND,R5   L(X'FFFFFFF3')
         STW,R5   3,R4
         SLS,R4   2
         B        *R7
DDLNK05  LI,R5    0
         STW,R5   VARFL             CLEAR VAR FLAG
         STW,R5   PLEVL
DDLNK1   BAL,R7   DDLNK02
         SLS,R4   -2
         LW,R5    3,R4
         SLS,R4   2
         AND,R5   L(X'F000')        H FIELD
         CI,R5    X'B000'
         BGE      DDLNK14           REPORT, COMPILER GEN ITEM
         LB,R5    2,R4
         AND,R5   L(X'7F')          LEVEL NUMBER
         LB,R6    5,R4              TDB NUMBER
         CI,R6    50
         BG       DDLNK11
DDLNK10  CW,R5    PLEVL
         BG       DDLNK14           SUBORDINATE
         LI,R5    0
         STW,R5   PLEVL
DDLNK14  BAL,R7   DDLNK04
         B        DDLNK2
DDLNK11  LH,R6    *PDBZ+4,R6        TDB OFFSET
         AW,R6    PDBZ+3            BA OF TDB
         LB,R6    0,R6
         AND,R6   L(X'8')           VAR REC = 8 OR 9                    COBOL21
         BEZ      DDLNK10                                               COBOL21
         LW,R6    PLEVL
         BNEZ     DDLNK13
         STW,R5   VARFL             SET VAR FLAG
         B        DDLNK12
DDLNK13  CW,R5    R6
         BG       DDLNK14           SUBORDINATE
DDLNK12  STW,R5   PLEVL
         LI,R5    4
         SLS,R4   -2
         OR,R5    3,R4
         STW,R5   3,R4              SET BIT 0 OF K
         SLS,R4   2
DDLNK2   AW,R4    R3                POINT TO LAST BYTE
         AI,R2    0
         BLEZ     DDLNK3            END OF SEGMENT
         STB,R3   0,R4
         AI,R4    1
         B        DDLNK1            NEXT ENTRY
DDLNK3   STB,R2   0,R4              SET LAST FLAG
         LW,R5    VARFL             END OF SEGMENT
         BEZ      DDLNK8
         STW,R2   PLEVL
DDLNK4   SW,R4    R3
         LB,R5    2,R4              LEVEL NO.
         AND,R5   L(X'7F')
         SLS,R4   -2
         CI,R5    1
         BE       DDLNK7            01
         BL       DDLNK5            H = C
         LW,R6    3,R4
         AND,R6   L(X'4')
         BEZ      DDLNK6            NOT DEPENDING ON
         STW,R5   PLEVL
         MTW,0    PNVLVL
         BLZ      DDLNK5            VAR REC ENCOUNTERED
         CW,R5    PNVLVL
         BL       DDLNK41
         LI,R1    76
         BAL,R11  DIAG
DDLNK41  LI,R5    -1
         STW,R5   PNVLVL
DDLNK5   SLS,R4   2
         AI,R4    -1
         LB,R3    0,R4              BYTE LENGTH
         B        DDLNK4
DDLNK6   LW,R6    PLEVL
         BNEZ     DDLNK62
         MTW,0    PNVLVL
         BLZ      DDLNK5
         CW,R5    PNVLVL
         BGE      DDLNK5
         STW,R5   PNVLVL
         B        DDLNK5
DDLNK62  CW,R5    R6
         BG       DDLNK5
         BL       DDLNK64           VAR REC GROUP
         LI,R6    0
         STW,R6   PLEVL             RESET PLEVL
         B        DDLNK5
DDLNK64  STW,R5   PLEVL
         LI,R5    8
         OR,R5    3,R4
         STW,R5   3,R4              SET BIT 0 OF K
         B        DDLNK5
DDLNK7   LW,R5    VARFL             VAR GROUP FLAG
         BEZ      DDLNK8
         LI,R5    8
         OR,R5    3,R4
         STW,R5   3,R4              SET BIT 0 OF K
DDLNK8   RES      0                                                     COBOL21
         LI,R1    -6                CK ALL DISPLACEMENTS SIZE           COBOL21
BASE:SIZ LW,R5    BASENUM,R1        LOAD DISP COUNTER                   COBOL21
         CI,R5    X'7FFFF'                                              COBOL21
         BG       BASE:ERR          ISSUE DIAG                          COBOL21
         BIR,R1   BASE:SIZ          LOOP                                COBOL21
         B        DDLNK9            OK--WRITE RECORD                    COBOL21
BASE:ERR RES      0                                                     COBOL21
         LI,R1    280               SECTION EXCEEDED 65K                COBOL21
         BAL,R11  DIAG                                                  COBOL21
DDLNK9   RES      0                                                     COBOL21
         LCI      7                                                     COBOL21
         LM,R1    DDREG
         BAL,R11  WRDDD              ON OUTPUT FILE
         BAL,R11  MDP
         LW,R4    SEGNUM
         SLS,R4   14
         LW,R6    SEGLNGTH
         BEZ      OUTOUT
         CW,R6    PDBMSL
         BLE      %+2                NO CHANGE
         STW,R6   PDBMSL             SET MAX SEG LENGTH (WORDS)
*        ABOVE CODE ADDED SO THAT COBOL34 CAN RESERVE SPACE FOR DDD BUF
         AW,R6    R4
         STW,R6   SEGID
         LI,R2    4
         LI,R4    BA(SEGID)         WRITE CURRENT SEGMENT NO. AND LENGTH
         BAL,R11  WRDDD              (IN WORDS) ON OUTPUT FILE
OUTOUT   MTW,1    SEGNUM            BUMP SEGMENT NUMBER
         LI,R2    0
         CW,R2    EOFFLAG           HAS END OF EDF BEEN REACHED?
         BEZ      %+2                NO
         STW,R6   PDBO               YES - STORE SEG# AND LENGTH IN PDB
         MTW,0    SQFIL             DID WE GO THRU SQUEEZ               COBOL21
         BEZ      OUTOUT1           NO                                  COBOL21
         STW,R2   SQFIL             TURN FLAG OFF                       COBOL21
         CW,R1    SQSIZ             SEE WHICH SIZE IS GREATER           COBOL21
         BG       OUTOUT1           USE NEW DDD SIZE                    COBOL21
         LW,R1    SQSIZ             USE OLD DDD SIZE BEFORE SQUEEZ      COBOL21
         STW,R2   SQSIZ                                                 COBOL21
OUTOUT1  RES      0                                                     COBOL21
         STW,R2   *DLORG,R1         CLEAR DLIST WORK AREA
         BDR,R1   %-1
         STW,R2   *DLORG
         STW,R2   SEGLNGTH
         LW,R1    DLORG
         STW,R1   DLPNTR            RESET DLIST POINTER
         LCI      5
         LM,R1    OSTEMP
         B        *OSEXIT
OSEXIT   RES      1
OSTEMP   RES      5
SEGID    DATA     0
REDSZ    DATA     0                 SAVE 01 SIZE                        COBOL21
         TITLE    'DATA MAP CLUSTER PROCESSOR'
         PAGE
MDP      LI,R3    6
         AND,R3   PDBCC
         OR,R3    ON:LINE           IF TEST OPTION, FORCE DMAP          COBOL21
         BEZ      *R11              DATA MAP NOT REQUESTED
         LW,R3    DLORG
         LI,R4    X'F000'
         AND,R4   3,R3
         BEZ      *R11              MNEMONIC NAME
         CI,R4    X'4000'
         BE       *R11              REPORT
         LW,R5    4,R3
         LB,R5    R5                BASE
         CI,R5    X'FF'
         BE       *R11              LINKAGE
         LW,R6    SEGLNGTH
         STW,R11  SAVR11
MDP1     SLS,R4   12
         LB,R5    R4                                                    COBOL21
         CI,R5    12                                                    COBOL21
         BL       MDP1%                                                 COBOL21
         LW,R4    MDPCL+2           GET CURRENT BASE
         AND,R4   =X'FF000000'
MDP1%    RES      0                                                     COBOL21
         STW,R4   MDPCL+2           F OF MDF
         LW,R5    3,R3
         AND,R5   L(X'FFFF0000')
         STW,R5   MDPCL             L OF MDF
         LW,R4    1,R3
         STH,R4   MDPCL+1           C OF MDF
         SLS,R4   -16
         OR,R4    MDPCL
         STW,R4   MDPCL             B OF MDF
         LW,R4    4,R3
         AND,R4   L(X'00FFFFFF')
         OR,R4    MDPCL+2
         STW,R4   MDPCL+2           D OF MDF
         LW,R4    5,R3
         AND,R4   L(X'0000FFFF')
         STW,R4   MDPCL+3           E OF MDF
         LW,R4    2,R3
         AND,R4   L(X'7F000000')
         SCS,R4   8
         CI,R4    1
         BNE      MDP2
         CW,R5    L(X'FFFF0000')
         BE       MDP7
         STW,R5   RECRDN            SAVE 01 REF NUMBER
         LW,R5    SECNT
         BEZ      MDP8
         LW,R4    FIR01
         BEZ      MDP8              NOT FIRST 01
         MTW,-1   FIR01
         LW,R4    FILTYP
         B        MDP8+1
MDP8     LW,R4    FILTYN
         CI,R4    8
         BE       MDP4              FILE-01
         STB,R4   MDPCL+2
         CI,R4    X'0B'
         BNE      MDP5              NOT COMMON-STORAGE
         MTB,-1   MDPCL+2
         B        MDP5
MDP2     CW,R5    L(X'FFFF0000')
         BE       MDP6              FILLER
         CI,R4    50
         BGE      MDP5
MDP3     LW,R4    RECRDN
         OR,R4    MDPCL+3
         STW,R4   MDPCL+3           H OF MDF
MDP4     LW,R4    FILEN
         LI,R2    3
         STH,R4   MDPCL,R2          G OF MDF
         REF      ON:LINE                                               COBOL21
MDP5     RES      0                                                     COBOL21
         LI,R4    X'0F0F'           I & K FIELDS FROM DDD               COBOL21
         AND,R4   3,R3                  +                               COBOL21
         LW,R2    7,R3              S FIELD FROM DDD                    COBOL21
         SLS,R2   -16                                                   COBOL21
         STH,R2   R4                TO SIXTH WORD OF                    COBOL21
         STW,R4   MDPCL+5                MDF                            COBOL21
         LW,R2    6,R3              Q & R FIELDS OF DDD                 COBOL21
         STW,R2   MDPCL+4              TO FIFTH WORD OF MDF             COBOL21
         LI,R2    24                                                    COBOL21
         LI,R4    BA(MDPCL)
         BAL,R11  WRMDF             OUTPUT MDF
MDP6     LW,R5    0,R3
         AND,R5   L(X'FF000000')
         SCS,R5   8
         SW,R6    R5
         BLEZ     *SAVR11           END OF SEGMENT
         AW,R3    R5
         LI,R4    X'F000'
         AND,R4   3,R3
         B        MDP1
MDP7     LI,R5    0                 01 - FILLER
         STW,R5   RECRDN
         LW,R4    FIR01
         BEZ      MDP6
         MTW,-1   FIR01             FIRST 01
         B        MDP6
FILTYP   DATA     0
FILTYN   DATA     0
FIR01    DATA     0
SECNT    DATA     0
NUL01    DATA     0
SAVR11   RES      1
RECRDN   RES      1                 REF NO-RECORD
FILEN    RES      1                       -FILE
REGR5    GEN,8,24 6,BA(MDPCF)
MDPCL    RES      6                 MDF BUFFER                          COBOL21
MDPCF    RES      4                                                     COBOL21
         DATA     0,0                                                   COBOL21
         TITLE    'SPECIFICATIONS CLUSTER PROCESSOR'
         PAGE
SPEC     LI,R7    14                IS CLASS IN DICT. SET
         LB,R3    *DLPNTR,R7
         AND,R3   L(X'F')
         BEZ      SPEC0              NO
         LH,R3    *PDLX              YES - IS USAGE COMP, COMP-1,
         AND,R3   L(X'74')           COMP-Z, OR INDEX
         BEZ      SPEC0               NO
         LI,R1    80                  YES - ERROR - PICTURE CLAUSE
         BAL,R11  DIAG                INVALID ON FIXED FORMAT ITEM
         LB,R3    *DLPNTR,R7        REMOVE CLASS
         AND,R3   L(X'F0')          USAGE TAKES PRECEDENCE
         STB,R3   *DLPNTR,R7
SPEC0    LI,R7    1
         AI,R2    1
         LB,R3    0,R2              GET SPECIFICATION FROM CLUSTER
         LB,R4    *PDLX,R7          GET SPECIFICATIONS FIELD FROM PDL
         BEZ      SPEC1             ANY SPEC. BITS SET
         OR,R3    R4                 YES - IS SPEC. BIT AND CURRENT SPEC
         CI,R3    X'81'              JUSTIFIED RIGHT AND USAGE DISPLAY
         BE       SPEC1               YES - ALLOWABLE COMBINATION
         CI,R3    X'82'              OR BLANK WHEN ZERO + USAGE DISPLAY
         BE       SPEC1
         LI,R1    66                  NO - ERROR - DISCARD CLUSTER
         BAL,R11  DIAG
         B        M1
SPEC1    STB,R3   *PDLX,R7          STORE SPEC. FROM CLUSTER IN PDL
         AND,R3   L(X'8B')
         BNEZ     M1                NO POSSIBILITY OF SLACK BYTES REQ.
         LB,R3    0,R2
         AND,R3   L(X'10')          TEST FOR POSSIBLE REQUIRED
         BEZ      SPEC2              GENERATION OF SLACK BYTES
         LI,R12   7                 DOUBLEWORD ALIGNMENT NECESSARY
         LI,R4    X'FFFF8'
         B        SPEC3
SPEC2    LI,R12   3                 WORD ALIGNMENT NECESSARY
         LI,R4    X'FFFFC'
SPEC3    LB,R6    SHFLG
         EXU      SPECADD-8,R6
         AND,R12  R4                DISPLACEMENT NOW ADJUSTED
         EXU      SPECSTOR-8,R6      TO REQUIRED BOUNDARY
         LW,R15   L(X'FFFFFF')      SET MASKS AND INDICES
         LW,R13   R15
         LI,R7    4
         LI,R6    1
         LW,R5    PDLX
         LS,R14   *DLPNTR,R7        GET OLD DISP FOR PDL COMPARE
         STS,R12  *DLPNTR,R7        STORE NEW DISP IN FOR
SPEC4    AI,R5    -2                BACK UP ONE ENTRY IN PDL
         LH,R4    *R5,R6            GET CURRENT DPOINT
         AW,R4    DLORG             ADD BASE OF DICT. SEGMENT
         CS,R14   *R4,R7            OLD DISPLACEMENTS EQUAL?
         BNE      M1
         STS,R12  *R4,R7            YES - STORE NEW DISP IN CURRENT EOR
         CI,R5    PDL               MORE ENTRIES IN PDL?
         BNE      SPEC4
         B        M1                NO - EXIT
SPECADD  AW,R12   DISP
         AW,R12   BASE1DSP
         AW,R12   BASEFDSP         LINKAGE
         AW,R12   BASE9DSP
         AW,R12   DISP
SPECSTOR STW,R12  DISP
         STW,R12  BASE1DSP
         STW,R12  BASEFDSP         LINKAGE
         STW,R12  BASE9DSP
         STW,R12  DISP
         TITLE    'PICTURE CLUSTER PROCESSOR'
         PAGE
PIC      LH,R3    *PDLX             HAS USAGE COMP, C-1, C-2, OR INDEX
         AND,R3   L(X'74')           BEEN FOUND ON CURRENT DATA ENTRY
         BEZ      PIC0               NO
         LI,R1    -80                YES - ERROR - PICTURE CLAUSE
         BAL,R11  DIAG               INVALID ON FIXED FORMAT ITEM
         B        M1                 DISCARD PICTURE
PIC0     LI,R7    14
         LB,R3    *DLPNTR,R7
         AND,R3   L(X'F')           IS CLASS IN DICT. SET?
         BEZ      PIC1              NO - SET IT
         AI,R3    1                 YES
         B        PIC2
PIC1     AI,R2    3                 MOVE CLASS FROM CLUSTER TO
         LB,R3    0,R2               CLASS IN STORAGE ITEM
         LB,R4    *DLPNTR,R7
         AW,R4    R3
         STB,R4   *DLPNTR,R7
         AI,R2    -2
PIC2     SLS,R2   -1
         LH,R4    0,R2              MOVE SIZE FIELD FROM CLUSTER
         LI,R7    11                TO STORAGE ITEM
         STH,R4   *DLPNTR,R7
         CI,R3    1                 IS CLASS ALPHANUMERIC?
         BE       M1                 YES - NO FURTHER ACTION - EXIT
         CI,R3    6                 IS CLASS NUMERIC DISPLAY SIGNED?
         BE       PICND
         CI,R3    7                 IS CLASS NUMERIC DISPLAY UNSIGNED?
         BE       PICND
         CI,R3    5                 IS CLASS NUMERIC EDITED?
         BE       PICNE
         LI,R3    4                 CLASS IS, BY DEFAULT ALPHA. EDITED
         BAL,R11  PICSET
         LB,R4    0,R2              GET LENGTH OF MASK DESCRIPTOR
         AI,R4    1
         LI,R3    BA(PICSAV)+4
         STB,R4   R3                MOVE MASK DESCRIPTOR FROM CLUSTER
         MBS,R2   0                  TO PIC. INFO. SAVE AREA
         AWM,R4   PICSAVCT          UPDATE LENGTH OF PIC. INFO.
         LB,R3    *DLPNTR            AND DICT.
         AW,R3    R4
         STB,R3   *DLPNTR
         BAL,R11  BLDPOF
         B        M1
BLDPOF   STW,R11  BPOFEXIT          CONSTRUCT POF ENTRY IN
         LI,R7    11                 CLUSTER INPUT AREA
         LH,R1    *DLPNTR,R7        GET LENGTH OF EDITING MASK IN BYTES
         AI,R2    -1
         STB,R1   0,R2              STORE IN POF (J FIELD)
         LW,R8    R1                SAVE FOR LATER UPDATING OF DISP.
         AI,R1    9                 ADD LENGTH OF OTHER POF INFO. REQ.
         SLS,R1   -1                CNVT. TO LENGTH IN HALFWORDS
         LW,R6    BASE4DSP
         LI,R7    1
         STH,R6   PICSAV,R7         SAVE DISPLACEMENT
         AW,R6    L(X'4000000')     FORMAT BASE NO. AND DISP. IN R6
         AI,R2    -4
         STW,R2   R5
         LI,R3    4
         STB,R3   R5
         LI,R4    24                MOVE R6 TO B AND D FIELDS OF POF
         MBS,R4   0
         AI,R2    -1
         LI,R3    X'2D'
         STB,R3   0,R2              SET POF CONTROL BYTE TO ALPHA DISPLY
         AI,R2    -1                 (C FIELD)
         STB,R1   0,R2              STORE POF CLUSTER LENGTH
         AWM,R8   BASE4DSP          UPDATE BASE 4 DISPLACEMENT
         LW,R4    R2
         BAL,R11  WRPOF             OUTPUT DATA DEF. ENTRY TO POF
         B        *BPOFEXIT
BPOFEXIT RES 1
PICND    LI,R3    2                 CLASS NUM. DISPLAY SIGNED OR UNSIGND
         BAL,R11  PICSET
         B        M1
PICSET   STW,R3   PICSAVCT          STORE LENGTH OF PICTURE INFO.
         LB,R4    *DLPNTR            AND ALSO ADD IT TO LENGTH
         AW,R4    R3                 OF DICT. ENTRY
         STB,R4   *DLPNTR
         SLS,R2   1
         AI,R2    3
         LI,R3    BA(PICSAV)        GET POINT LOCATION OR NO. OF CHAR.
         LI,R4    2                  POSITIONS AND SAVE
         STB,R4   R3
         MBS,R2   0
         B        *R11
PICNE    LI,R3    10                CLASS NUMERIC EDITED
         BAL,R11  PICSET
         LI,R3    BA(PICSAV)+4
         LI,R4    6
         STB,R4   R3                MOVE FIXED NE INFO. FROM CLUSTER
         MBS,R2   0                  TO PIC. INFO. SAVE AREA
         BAL,R11  BLDPOF
         B        M1
         TITLE    'VALUE CLUSTER PROCESSOR'
         PAGE
VAL      LB,R3    SHFLG             IF IN REPORT SECTION
         STW,R2    SAV2                                                 COBOL21
         CI,R3    X'C'               AND NOT GROUP INDICATE OR SUM
         BNE      %+3                SET REPORT VALUE FLAG
         LW,R3    GISUMFLG           ELSE DEFER VALUE FOR VPROC
         BEZ      VAL10
         AI,R2    1                  MOVE VALUE SEQUENCE NUMBER FROM
         SLS,R2   -1                 CLUSTER TO SYN LINK FIELD IN DICT
         LH,R3    0,R2               FOR TEMP STORAGE
         LW,R4    L(X'FFFFFF')
         AND,R4   *DLPNTR           CHECK FOR SYN LINK FIELD BEING
         BEZ      VAL1               OCCUPIED
         LI,R1    67                ERROR - MULTIPLE VALUE CLAUSES
         BAL,R11  DIAG               DISCARD CURRENT CLUSTER
         B        M1
VAL1     AWM,R3   *DLPNTR
         LI,R7    7                 SEARCH PDL FOR SET VALUE BIT.
         LW,R4    PDLX               IF FOUND, ERROR - VALUE WITHIN
VAL3     LB,R3    *R4,R7             SCOPE OF ANOTHER VALUE
         BNEZ     VAL5
         CI,R4    PDL
         BE       VAL7
         AI,R4    -2
         B        VAL3
VAL5     LW,R3    LEVNUM
         CB,R3    *PDLX
         BLE      VAL7
         LI,R1    84
         BAL,R11  DIAG
VAL7     LI,R1    1
         AWM,R1   *PDLX,R1          SET VALUE BIT IN PDL
         LW,R3     GISUMFLG        IS GROUP INDICATE FLAG ON?           COBOL21
         BEZ       M1              NO                                   COBOL21
VAL10    LI,R3    BA(RVFLAG)        SAVE REPORT VALUE CLUSTER
         LI,R4    4                  SEQUENCE NO.
         STB,R4   R3
         LW,R2     SAV2                                                 COBOL21
         AI,R2    1
         MBS,R2   0
         B        M1
PRVAL    STW,R11  RVEXIT
         LCI      7
         STM,R1   RVTEMP
         LW,R3    RVFLAG            IS REPORT VALUE FLAG SET
         BEZ      VAL105            NO - RETURN
         LW,R3     GISUMFLG        IS GROUP INDICATE FLAG ON?           COBOL21
         BEZ       VAL11           NO                                   COBOL21
         BAL,R11   VPROC           PROCESS VALUE AT VPROC               COBOL21
         LI,R4     0                                                    COBOL21
         STW,R4    RVFLAG          CLEAR VALUE FLAG                     COBOL21
         B         VAL105          RETURN                               COBOL21
VAL11    RES       0                                                    COBOL21
         BAL,R11  RDIVF             GET IVF ENTRY
         LI,R3    BA(RVFLAG)
VAL12    AI,R2    1
         LI,R4    2                 IS IVF VALUE SEQ. NO. EQUAL TO
         STB,R4   R3                 EDF VALUE SEQ. NO.?
         CBS,R2   0
         BE       VAL15              YES
         BG       VAL200             NO - TROUBLE - IVF GREATER THAN EDF
         BAL,R11  RDIVF             IVF LESS THAN EDF
         BLZ      VAL105            END OF IVF
         B        VAL12              TRY AGAIN
VAL15    LI,R4    0                 RESET REPORT VALUE FLAG
         STW,R4   RVFLAG
         LI,R7    24                DOES CURRENT DATA ENTRY HAVE
         LB,R4    *DLPNTR,R7         COLUMN NO.?
         BNEZ     VAL25              YES
         LW,R4    GISUMFLG           NO - IS GROUP INDICATE FLAG SET?
         BNEZ     VAL25              YES
         LI,R1    97                  NO - ERROR
         BAL,R11  DIAG                VALUE ILLEGAL WITHOUT COLUMN NO.
         B        VAL105
VAL25    LI,R7    11
         LB,R4    0,R2              GET VALUE TYPE IN IVF
         AND,R4   L(X'F0')
         CI,R4    X'C0'
         BL       VAL30             FIG. CONST. OR STRING
         LI,R1    98                NUMERIC - NOT VALID IN REPORT SECT.
         BAL,R11  DIAG
         B        VAL105
VAL30    LH,R3    *DLPNTR,R7        GET SIZE OF DATA ENTRY
         CI,R4    X'B0'             GO TO VAL60 IF STRING
         BE       VAL60              ELSE FIGURATIVE CONSTANT
         LI,R7    24                GET STARTING COLUMN ON REPORT LINE
         LB,R1    *DLPNTR,R7         FOR PLACEMENT OF FIGCON
         AI,R1    BA(RLINEBUF)+7    ADD REPORT LINE ORIGIN
         STB,R3   R1                SET COUNT
         LB,R5    0,R2              GET FIGCON TYPE FROM IVF
         AND,R5   L(X'F')
         LB,R6    FCCHAR,R5         GET CORRESPONDING EBCDIC CHAR.
         MBS,0    27                MOVE CHAR ITERATIVELY TO RPT. LINE
         B        VAL105
VAL60    LB,R4    0,R2              DETERMINE STRING TYPE
         AND,R4   L(X'F')
         BEZ      VAL100            SIMPLE STRING
         AI,R2    2                 ALL STRING - GET LENGTH OF
         LB,R4    0,R2               ONE REPETITION
         CW,R4    R3                IS ONE REPETITION OF ALL STRING
         BLE      %+4                GREATER THAN DICT. SIZE?
         LI,R1    106                YES - VALUE RIGHT TRUNCATED
         BAL,R11  DIAG
         LW,R4    R3
         LI,R7    24
         LB,R7    *DLPNTR,R7        GET COLUMN NUMBER
         AI,R7    BA(RLINEBUF)+7
         LW,R6    R2
         AI,R6    1
VAL80    STB,R4   R7                STORE ONE REP. OF ALL STRING IN
         MBS,R6   0                  REPORT LINE
         SW,R3    R4                SUBT ALL REP LNGTH FROM DICT LNGTH
         BEZ      VAL105            NO MORE NEEDED
         SW,R6    R4                RESET ALL STRING POINTER
         CW,R4    R3                COMP ALL REP LNGTH TO REM DICT LNGTH
         BLE      VAL80             ANOTHER FULL ITERATION REQUIRED
         STB,R3   R7
         MBS,R6   0                 MOVE LAST PARTIAL STRING
         B        VAL105
VAL100   AI,R2    2
         LB,R4    0,R2              GET LENGTH OF STRING
         CW,R4    R3                COMPARE STRING TO DATA ENTRY SIZE
         BLE      %+4
         LW,R4    R3                GREATER - EXCESS RIGHT TRUNCATED
         LI,R1    106
         BAL,R11  DIAG
         LI,R7    24
         LB,R7    *DLPNTR,R7        GET COLUMN NUMBER
         LW,R5    R4                                                    COBOL21
         AW,R5    R7                COLUMN NO PLUS SIZE OF STRING       COBOL21
         CI,R5    134                                                   COBOL21
         BLE      VAL101                                                COBOL21
         AI,R5    -134                                                  COBOL21
         SW,R4    R5                TRUNCATE SIZE TO  134               COBOL21
         LI,R5    11
         STH,R4   *DLPNTR,R5        CHG SIZE IN DDD
         LI,R1    106               ISSUE DIAG FOR VALUE TRUNC ON RGT   COBOL21
         BAL,R11  DIAG                                                  COBOL21
VAL101   RES      0                                                     COBOL21
         AI,R7    BA(RLINEBUF)+7
         LW,R6    R2
         AI,R6    1
         STB,R4   R7
         MBS,R6   0                 MOVE STRING TO REPORT LINE
VAL105   LCI      7
         LM,R1    RVTEMP
         B        *RVEXIT
VAL200   CAL1,1   VAL200PT
         B        *RVEXIT
VAL200PT GEN,8,24 X'11',M:LO
         DATA     X'30000010'
         DATA     VAL200PM
         DATA     25
VAL200PM TEXT     'EDF-IVF SEQ. NO. MISMATCH'
FCCHAR   DATA     X'F0407D00'
         DATA     X'FF000000'
         TITLE    'DESCRIPTION BLOCK CLUSTER PROCESSOR'
         PAGE
DB       AI,R2    -1                GET TOTAL LENGTH OF DB CLUSTER
         LB,R1    0,R2              SUBTRACT LENGTH OF FIXED INFORMATION
         AI,R1    -5                LEAVING ACTUAL DB LENGTH
         STW,R1   DBL               SAVE FOR LATER
         STW,R2   SAVR11            SAVE DB BYTE ADDR
         AI,R2    6                 SAVE SOURCE LINE NO. AND SUB
         LI,R3    BA(DBLINE)         FOR LATER INSERTION IN DESC. BLOCK
         LW,R4    DBLINE            SAVE PREVIOUS DESC. BLOCK LINE NO.
         STW,R4   DBLPREV           FOR POSSIBLE LATER DIAGNOSTIC
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         AI,R2    -7
         LI,R1    0
         STW,R1   LEVNUM            SET PSEUDO LEVEL NUMBER
         LB,R1    0,R2              GET DB# FOR LATER
         LW,R4    R1
         AI,R2    -1
         XW,R1    DESBNUM           LOAD PREV. DB# FOR TERFIL, IF REQ.
         LB,R6    0,R2
         AND,R6   L(X'F')           GET DB TYPE
         AI,R6    -1
         LI,R3    6
         AND,R3   PDBCC
         OR,R3    ON:LINE                                               COBOL21
         BEZ      DB16              NO DMAP REQUESTED
         CI,R6    4
         BE       DB16
         STB,R6   MDPCF+2           SAVE FOR F OF
         XW,R4    SAVR11
         LW,R5    REGR5
         MBS,R4   4                 L, B AND C OF MDF
         LW,R4    SAVR11
DB16     CI,R6    5
         BL       DBVECT,R6
         B        DBTERR
DBVECT   B        DBTERR            1 - ERROR
         B        DDB               2 - DATA DESC BLOCK
         B        SDB               3 - SORT DESC BLOCK
         B        RDB               4 - REPORT DESC BLOCK
         B        TDB               5 - TABLE DESC BLOCK
DDB      RES      0
SDB      STW,R4   DBNTNUM           SAVE CURRENT DB# FOR LATER
         AI,R4    110               COMPUTE CURRENT DCB BASE NO.
         LW,R6    R2                 = CURRENT DESC. BLOCK NO. + 110
         AI,R6    44                 AND STORE IN P FIELD OF CURRENT
         STB,R4   0,R6              FILES DESC. BLOCK
         AI,R4    -110
RDB      LW,R3    SEGNUM            STORE CURRENT SEGMENT NO. IN
         LW,R6    R2                 E FIELD OF CURRENT FILES
         AI,R6    12                 DESC. BLOCK
         SLS,R6   -1
         AH,R3    0,R6
         STH,R3   0,R6
DB02     LW,R3    PDLX
         CI,R3    PDL               IS PDL EMPTY?
         BE       DB15               YES
         LW,R3    *DLORG             NO - IS DICT. WORK AREA EMPTY
         BEZ      DB15+1              YES
         MTH,1    0,R6               ADJUST SEG. NO.
         BAL,R11  PROCESS           FLUSH THE PDL
         LW,R3    LRFLAG            IS LABEL RECORD FLAG SET
         BEZ      DB03               NO
         LW,R3    BASE10DP          IS CURRENT LABEL RECORD
         CW,R3    MAXLAB             LARGER THAN ANY PREV. LAB. RCD.
         BLE      %+2                NO
         STW,R3   MAXLAB            UPDATE MAX. LABEL RCD. LENGTH
         LI,R3    0
         STW,R3   BASE10DP          RESET LABEL DISP. COUNTER
         STW,R3   LRFLAG             AND LABEL RCD. FLAG
DB03     LI,R3    X'C'              PROCESSING IN REPORT SECTION
         CB,R3    SHFLG
         BNE      RDB1              NO
         LW,R3    FRSTRDB           YES-IS THIS 1ST RDB
         BEZ      RDB1              NO
         LI,R3    0                 YES-RESET FLAG
         STW,R3   FRSTRDB
         LI,R3    3
         STW,R3   ADDDL
         LCI      8                                                     COBOL21
         STM,R1   DBTEMP            SAVE REGISTERS                      COBOL21
         BAL,R11  OUTINDX           SEE IF DDD SHOULD GO OUT            COBOL21
         LCI      8                                                     COBOL21
         LM,R1    DBTEMP            RESTORE REGISTERS                   COBOL21
         B        %+2
RDB1     BAL,R11  TERFIL
          LI,R3   0
          STW,R3  L77FLG
          STW,R3  FSTWSCS
          STW,R3  OVERLAP
          CW,R3   L66FLG            IS LEVEL 66 FLAG SET
          BE      DB05              NO
          STW,R3  L66FLG            YES - RESET AND BYPASS VPROC,SYNLNK
          B       DB12
DB05      BAL,R11 VPROC
         LW,R3    FILFLG            IS FILLER FLAG ON                   COBOL21
         BEZ      DB1               NO                                  COBOL21
         BAL,R11  SQUEEZ            GO TO SQUEEZ OUT FILLER             COBOL21
DB1       BAL,R11 SYNLNK
DB12      BAL,R11 OUTSEG
DB15     MTW,2    PDLX
         AI,R2    2
         AI,R4    10                COMPUTE CURRENT RCD. AREA BASE NO.
         STW,R4   BASENUM            = CURRENT DB NO. + 10
         LI,R3    6
         AND,R3   PDBCC
         OR,R3    ON:LINE                                               COBOL21
         BEZ      DB17
         LH,R4    MDPCF
         STW,R4   FILEN             SAVE FILE REF NO.
         STW,R2   SAVR11
         LI,R2    16
         LI,R4    BA(MDPCF)
         BAL,R11  WRMDF             OUTPUT MDF
         LW,R2    SAVR11
DB17     LI,R3    X'2006'           DMAP AND/OR XREF
         AND,R3   PDBCC              BEEN REQUESTED?
         BEZ      DB18               NO
         LW,R12   L(X'05010000')     YES - CONSTRUCT AND OUTPUT A
         LI,R3    50                 DATA DEFINITION CLUSTER TO
         LI,R5    6                  THE CROSS REFERENCE FILE
         STB,R5   R3
         MBS,R2   0
         LI,R4    48                BA(R12)
         BAL,R11  WRXRF
         AI,R2    -6
DB18     SLS,R2   -1
         LH,R3    0,R2              MAKE DINDEX ENTRY CONTAINING
         LW,R5    DXORG              SEG # (0 FOR DESC BLOCKS) AND
         AW,R5    R3                 DISPLACEMENT
         OR,R5    L(X'3000000')
         LW,R3    DBPNTR
         SW,R3    DBORG
         LW,R7    R3
         LI,R4    13                BA(R3)+1
         MBS,R4   0
         AI,R2    3                                                 ****
         SLS,R2   1
DB2      LW,R3    DBL               GET LENGTH OF DB PORTION OF CLUSTER
         AI,R3    -1                                                    COBOL21
         SLS,R3   -1
         LW,R4    R3
         SCS,R3   -6
         AW,R3    DBPNTR
         MBS,R2   0
         LW,R2    DBLINE            STORE LINE NO. IN LAST WORD
         SLS,R3   -2                 OF DESC. BLOCK  (WORD ALIGNED)
         STW,R2   0,R3
         AI,R4    1
         LW,R1    DESBNUM           MAKE ENTRY AT DBINDX(DB#) CONTAINING
         STH,R7   *DBXORG,R1         DISP IN BYTES REL TO ORG OF DBINDX
         SLS,R4   2
         AWM,R4   DBPNTR            BUMP DB TABLE POINTER
         LW,R3    TDBFLG            IS TDB FLAG SET
         BEZ      M1                NO - EXIT
         STW,R3   DESBNUM           SAVE LAST NON-TDB NO. AND RESET FLAG
         LI,R3    0
         STW,R3   TDBFLG
         B        M1
TDB      STW,R1   TDBFLG            SAVE NON-TDB NO.
         MTW,1    TDBFLG2           TURN ON TDB FLG
         AI,R2    8
         LI,R3    4                 SET MIN. TDB LENGTH (HALFWORDS)
         LB,R4    0,R2              GET TDB ID
         CI,R4    7                 IS TABLE FIXED LENGTH?
         BLE      %+2                YES
         AI,R3    8                  NO - ADD DATA DESC. LENGTH TO TDB
         LW,R7    DBPNTR
         SW,R7    DBORG
         B        DB2+2
DBTERR   RES      0
         LI,R1    505
         BAL,R11  DIAG              COMPILER ERROR 05
         B        DDB               IF CONTINUE ASSUME DATA
DBL      RES      1                 CURRENT DB LENGTH  (IN BYTES)
DBLINE   RES      1                 CURRENT DESC. BLOCK LINE NO.
DBLPREV  RES      1                 PREVIOUS DESC. BLOCK LINE NO.
         TITLE    'DATA ENTRY AND FILLER CLUSTER PROCESSOR'
         PAGE
RPTFIL   STW,R2   SUMFLG            SET SUM FLAG
         B        FIL
NRE      LI,R3    0                 UNCONDITIONALLY CLEAR REPORT
         STW,R3   RPTDEADR           DATA ENTRY ADDRESS
         BAL,R11  PRVAL             PROCESS PREV RPT VALUE IF ANY
FIL      STW,R2   FILFLG            SET FILLER FLAG
         AI,R2    1
         B        DE0+1
RPTDE    BAL,R11  PRVAL             PROCESS PREV RPT VALUE IF ANY
         LB,R3    *DLPNTR           COMPUTE AND SAVE DICT. ADDRESS
         AW,R3    ADDDL             ROOM FOR TRAILING LENGTH
         SLS,R3   -2
         AW,R3    DLPNTR
         STW,R3   RPTDEADR          MAY BE NEEDED LATER FOR SUM
DE       AI,R2    5                 MOVE SOURCE LINE NO. AND SUB
         LI,R3    BA(CARDNO)         TO CARD NUMBER CELL IN CASE
         LI,R4    4                  DIAGNOSTIC MESSAGE REQUIRED
         STB,R4   R3
         MBS,R2   0
         LI,R3    X'2006'           DMAP AND/OR XREF
         AND,R3   PDBCC              BEEN REQUESTED?
         BEZ      DE0                NO
         LW,R12   L(X'05010000')     YES - CONSTRUCT AND OUTPUT A
         AI,R2    -6                 DATA DEFINITION CLUSTER TO
         LI,R3    50                 THE CROSS REFERENCE FILE
         LI,R4    6
         STB,R4   R3
         MBS,R2   0
         LI,R4    48                BA(R12)
         BAL,R11  WRXRF
DE0      AI,R2    -7
         LB,R3    0,R2              GET LEVEL NUMBER
         LW,R7    LEVNUM            GET MOST RECENT LEVEL NUMBER
*     IF LEVNUM  IS = 0 THEN CURRENT LEVEL NUMBER MUST BE = 1
*     IF NOT THEN FORCE IT TO BE, WHICH WILL ALSO CAUSE A DIAG
         CI,R7    0                 LAST LEVEL = 0 ?
        BNE      DE01              NO
         CI,R3    1                 CURRENT LEVEL = 1 ?
         BE       DE01              YES
         CI,R3    77
         BE       DE01
         MTW,0    TDBFLG2
         BEZ      %+3
         STW,R7   TDBFLG2           TURN FLG OFF
         B        DE01
         LI,R3    1                 FORCE = 1
         LI,R1    100
         BAL,R11  DIAG
DE01     RES      0
         STW,R3   LEVNUM            SAVE CURRENT DATA ENTRY LEVEL NUMBER
         CI,R3    50
         BL       DE1
         CI,R3    88
         BNE      DE05
         AI,R2    -1
         LB,R4    0,R2
         AI,R2    +1
         CI,R4    X'23'             IS LEVEL 88 ON A FILLER ENTRY
         BNE      L88               NO
         LI,R3    1                 ERROR - MISSING DATA NAME ON LEV 88
         STW,R3   LEVNUM             ENTRY.  PROCESS AS LEV 01 FILLER
         B        L1                PROPER ERROR MESS. OUTPUT IN PH 1.2
DE05     CI,R3    77
         BE       L77
         CI,R3    66
         BE       L66
         B        LEVER             UNDEFINED LEV NO.
DE1      CI,R3    1
         BE       L1
         LW,R4    L66FLG            IS LEVEL 66 FLAG SET?
         BNEZ     DE15              YES
         LW,R4    L77FLG            IS LEV 77 FLAG SET
         BEZ      RD1                NO
         LI,R1    100               YES - SHOULD BE 01 FOLLOWING 77
         BAL,R11  DIAG               PROCESS AS 01
         LI,R3    1
         B        L1
DE15     LI,R4    0
         STW,R4   L66FLG
         LI,R1    70                YES - FATAL ERROR
         BAL,R11  DIAG              L66 DID NOT FOLLOW LAST DATA ENTRY
L66E1    BAL,R11  RDEDF             IN RECORD
         AI,R2    1                 DISCARD ALL REMAINING CLUSTERS IN
         LB,R3    0,R2               CURRENT RECORD
         CI,R3    X'10'             LOOK FOR 1ST DESC. BLOCK,
         BE       DB                 SECTION HEADER, OR
         BL       L66E2              LEVEL 1 CLUSTER AND RESUME
         AI,R2    2                  PROCESSING
         LB,R3    0,R2
         CI,R3    1
         BE       L1
         B        L66E1
L66E2    AI,R3    -8                MUST BE WS, CS, OR RPT SECT HDR
         B        %,R3
RD1      CB,R3    *PDLX             IS MOST RECENT ENTRY IN PDL
         BG       DE2                AN ELEMENTARY ITEM?
         BAL,R11  REDEF             YES
DE2      BAL,R11  PROCESS
RD3      LW,R4    DXORG
         SLS,R4   -2
         SW,R4    DLPNTR
         CI,R4    9
         BGE      RD35
         LI,R4    X'4000'           DICT. WORK AREA OVERFLOW
         OR,R4    PDBP               FATAL ERROR
         STW,R4   PDBP               SET ABORT FLAG AND TERMINATE
         LI,R1    122
         BAL,R11  DIAG
         B        PH21E
RD35     LB,R4    *DLPNTR           MAKE STORAGE ITEM DICT. ENTRY
         AWM,R4   DLPNTR
         LI,R4    X'C'              IF REPORT SECTION SET C IN DICT
         CB,R4    SHFLG              TO 26
         BNE      %+3                ELSE A=24
         LI,R4    26
         B        %+2
         LI,R4    24
         STB,R4   *DLPNTR
         STB,R3   *PDLX             LEV NO. TO PDL AND E IN DICT.
         LI,R7    8
         STB,R3   *DLPNTR,R7
         AI,R2    -1
         LB,R3    0,R2
         CI,R3    X'23'
         BE       DE23
         CI,R3    X'34'
         BE       DE23
         CI,R3    X'36'
         BNE      DE24
DE23     LW,R4    CARDNO            MOVE LATEST LINE NO. TO
         LW,R5    DLPNTR             FILLER DICT. ENTRY
         AI,R5    1
         STW,R4   0,R5
         B        DE25
DE24     AI,R2    4                 MOVE SOURCE LINE NO. AND SUB
         LW,R3    DLPNTR             FROM CLUSTER TO DICT.
         AI,R3    1
         SLS,R3   2
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         AI,R2    -9                STORE ALL BITS IF FILLER
         LB,R3    0,R2               OR R# IN G OF DICT.
DE25     LI,R7    6
         CI,R3    X'21'
         BE       DE3
         CI,R3    X'33'
         BE       DE3
         LI,R3    X'C'              IF NAMELESS REPORT ENTRY
         CB,R3    SHFLG              STORE -2 IN R# OF DICT.
         BNE      %+3
         LI,R3    -2
         B        %+2
         LI,R3    -1
         STH,R3   *DLPNTR,R7
         B        DE4
DE3      SLS,R2   -1
         AI,R2    2
         LH,R3    0,R2
         STH,R3   *DLPNTR,R7
DE4      LB,R3    SHFLG             SET TYPE IN H OF DICT.
         CI,R3    9
         BLE      %+2               FILE OR WORKING-STORAGE
         AI,R3    -1                LINKAGE, COMMON-ST OR REPORT
         LI,R7    14
         SLS,R3   4
         STB,R3   *DLPNTR,R7
         LI,R7    15                STORE CURRENT LEVEL OF NESTING
         LCW,R3   OCCX               IN J OF DICT.
         AI,R3    OCCPDL-1
         LCW,R3   R3
         STB,R3   *DLPNTR,R7
         SCS,R3   -7                ADD (2 * LEV. OF NESTING)
         AWM,R3   *DLPNTR            TO LENGTH OF DICT. ENTRY
         LB,R6    SHFLG             GET DISPLACEMENT APPROPRIATE TO
         CI,R6    X'C'               SECTION BEING PROCESSED
         BNE      %+3
         LW,R3    RLINEDSP
         B        %+2
         EXU      GETDISP1-8,R6
         LI,R7    4
         STW,R3   *DLPNTR,R7
         LW,R3    LRFLAG            IF LABEL RECORD, SET BASE NO. TO 10
         BEZ      %+3                ELSE USE CURRENT BASE NO.
         LI,R3    10
         B        %+2
         EXU      GETBASE-8,R6      BASE NUMBER TO L OF DICT.
         LI,R7    16
         STB,R3   *DLPNTR,R7
         LI,R7    20
         CI,R6    X'C'              IS WITHIN REPORT SECTION
         BNE      DE45
         LW,R3    DESBNUM            RDB# TO N OF DICT.
         B        %+2
DE45     LB,R3    *OCCX              ELSE TDB#, IF ANY, TO N OF DICT.
         STB,R3   *DLPNTR,R7
         LW,R3    DLPNTR            STORE RELATIVE ADDRESS OF CURRENT
         SW,R3    DLORG              DICT. ENTRY IN CURRENT PDL ENTRY
         LI,R7    1
         STH,R3   *PDLX,R7
RD2      LW,R3    REDF              REDEFINITION FLAG SET?
         BEZ      DE5               NO
         LI,R3    128               SET LEVEL NUMBER FIELD IN CURRENT
         SCS,R3   -8                 DICT. ENTRY TO INDICATE REDEFINES
         LI,R7    2
         AWM,R3   *DLPNTR,R7
         EXU      GETDISP1-8,R6     SAVE CURRENT DISPLACEMENT IN
         LW,R2    R3
         LI,R3    X'7FFFF'          19-BIT
         SLD,R2   13
         LW,R4    PDLX
         STS,R2   1,R4              SET 19-BIT DISPLACEMENT
         LW,R3    RDISP             RESET DISP. TO BEGINNING OF
         EXU      STORDISP-8,R6      REDEFINED AREA
*  SIDR 11708 ADDED NEXT 4 INSTS.  IF THE CURRENT DISP WAS LARGER       COBOL21
*   THAN THE REDEDINE DISP, GARBAGE WAS LEFT IN THE 'M' FIELD           COBOL21
         LI,R7    4                                                     COBOL21
         LW,R2    *DLPNTR,R7                                            COBOL21
         AND,R2   =X'FFF00000'      SAVE BASE NO ONLY                   COBOL21
         OR,R2    R3                STORE RDISP INTO DDD                COBOL21
         STW,R2   *DLPNTR,R7                                            COBOL21
         LI,R3    0                 RESET REDEFINITION FLAG
         STW,R3   REDF
DE5      LW,R2    RAHEAD
         BLZ      ENDPH21
         BEZ      M1
         LI,R3    0                 RESET READ AHEAD FLAG
         STW,R3   RAHEAD
         B        M2-1
GETDISP1 LW,R3    DISP              FILE SECTION DISPLACEMENT
         LW,R3    BASE1DSP          WORKING-STORAGE SECTION
         LW,R3    BASEFDSP         LINKAGE
         LW,R3    BASE9DSP          COMMON-STORAGE SECTION
         LW,R3    DISP              REPORT SECTION
STORDISP STW,R3   DISP
         STW,R3   BASE1DSP
         STW,R3   BASEFDSP         LINKAGE
         STW,R3   BASE9DSP
         STW,R3   DISP
REDEF    STW,R11  DEEXIT
         LCI      6
         STM,R3   DETEMP
         AI,R2    -3                SAVE CURRENT DE CLUSTER
         LI,R3    BA(DECSA)
         LI,R4    12
         STB,R4   R3
         MBS,R2   0
RD40     BAL,R11  RDEDF
         BGEZ     %+3                                                   COBOL21
         STW,R2   RAHEAD                                                COBOL21
         B        RD5                                                   COBOL21
         AI,R2    1
         LB,R3    0,R2
         BEZ      RD40
         CI,R3    X'2B'             IS CLUSTER REDEFINES WITH DATA-NAME?
         BE       DE55
         CI,R3    X'2C'             RED. WITHOUT DATA-NAME?
         BE       DE6
RD4      BAL,R11  SAVEDF                                                COBOL21
RD5      LI,R2    BA(DECSA)+3       SET INPT PNTR TO LEV IN DAT ENT SAVA
         LCI      6
         LM,R3    DETEMP
         B        *DEEXIT
DE55     LI,R8    1                 SET REDEFINES WITH NAME INDICATOR
DE6      LI,R7    BA(DECSA)+3       GET LEVEL OF CURRENT REDEFINING
         LB,R3    0,R7               DATA ENTRY
         STB,R3   R12               SAVE LEVEL NO FOR LATER             COBOL21
         LW,R7    PDLX              GET CURRENT PDL POINTER SETTING
         SLS,R7   2
DE7      CB,R3    0,R7              SEARCH PDL FOR CLOSEST ENTRY WITH
         BE       DE10               LEVEL EQUAL TO CURRENT REDEFINING
         CI,R7    BA(PDL)            DATA ENTRY
         BE       DE8               NO ENTRY FOUND - ERROR
         AI,R7    -8
         B        DE7
DE8      LI,R1    68
         BAL,R11  DIAG              INCORRECT REDEFINITION
DE9      BAL,R11  RDEDF             READ IN AND DISCARD ANY REDEFINES
         AI,R2    1                  QUALIFIER CLUSTERS
         LB,R3    0,R2
         CI,R3    X'2B'
         BNE      RD4
         B        DE9
DE10     RES      0                                                     COBOL21
         CI,R3    1                 IS  LEVEL  A  01                    COBOL21
         BNE      DE10A             NO                                  COBOL21
         LW,R6    L66FLG            HAVE  WE  HAD  A  66                COBOL21
         BEZ      DE10A             NO                                  COBOL21
         LW,R6    DLORG             YES  GET  01  ADDR                  COBOL21
         B        DE10B                                                 COBOL21
DE10A    LW,R6    R7                                                    COBOL21
         SLS,R6   -1                MOVE DISP FROM DICT. ENTRY
         AI,R6    1                  ASSOCIATED WITH PDL ENTRY JUST
         LH,R6    0,R6               FOUND TO RDISP
         AW,R6    DLORG
DE10B    RES      0                                                     COBOL21
*
* THE FOLLOWING 4 INSTRUCTIONS ALLOW THE REDEFINITION OF LEVEL-77 ITEMS.
* AT THE TIME THE REDEFINES EDF CLUSTER (CONTROL BYTE 2B) IS ENCOUNTERED
* THE ENTRY CONTAINING THE REDEFINES CLAUSE HAS ALREADY BEEN ADDED TO
* THE DICTIONARY. THEREFORE WE MUST BACK UP 1 ENTRY IN ORDER TO ACCESS
* THE ENTRY BEING REDEFINED.
*
         LB,R3    0,R7
         CI,R3    77                IF LEVEL 77 ENTRY,
         BNE      %+2                  SUBTRACT LENGTH OF PREV DICT
         SW,R6    LPDE                 ENTRY TO ACCESS REDEFINED ENTRY
         STW,R6   MRC+1             SAVE DICT. ADDRESS IN CASE OF XRF
         AI,R6    4
         LW,R3    0,R6
         AND,R3   =X'FFFFF'         MASK OFF M FIELD OF DDD(20 BITS)    COBOL21
         STW,R3   RDISP
         STW,R6   REDF              SET REDF FLAG
         CI,R8    1
         BNE      RD5
         SLS,R6   1
         AI,R6    -2                DOES REDEFINES OBJECT NAME
         AI,R2    3                  MATCH PDL NAME?
         SLS,R2   -1
         LH,R3    0,R2
         CH,R3    0,R6
         BE       DE10E             YES - SAVE REF NO                   COBOL21
         AI,R6    -2                NO - IS ENTRY REDEFINES
         SLS,R6   -1
         LW,R13   L(X'80000000')                                        COBOL21
         AND,R13  0,R6                                                  COBOL21
         BEZ      DE8               NO - ERROR                          COBOL21
         LB,R13   *R6
         CI,R13   X'81'                 IF LEVEL 01 REDEFINE
         BNE      DE100             NOT 01 REDEFINES                    COBOL21
         CW,R3    ORGRN             ORIGINAL REDEFINED REF NO?          COBOL21
         BE       DE11              YES - USE IT                        COBOL21
         B        DE8               NO - ERROR                          COBOL21
DE100    RES      0                                                     COBOL21
         AI,R6    -2                                                    COBOL21
         CW,R6    DLORG
         BE       DE8               ERROR                               COBOL21
         STW,R6   R15
         LW,R6    DLORG             FIRST ENTRY
DE10C    SLS,R6   2                 BYTE  ADDR
         LB,R14   0,R6              LENGTH OF ENTRY
        LB,R13   2,R6
         AND,R13  =X'7F'
         SLS,R6   -2                WORD  ADDR
         CB,R13   R12                CHK FOR != LEVELS
         BNE      DE10D
         SLS,R6   1                 HALF WORD ADDR                      COBOL21
         CH,R3    3,R6             COMPARE REF NOS                      C62632
         BE       DE11              NAME FOUND                          COBOL21
         SLS,R6   -1                WORD ADDR                           COBOL21
DE10D    RES      0
         AW,R6    R14               ADDRESS OF NEXT ENTRY
         CW,R6    R15               IS THIS THE CLUSTER WHER WE STARTED
         BL       DE10C              NO
         B        DE8                                                   COBOL21
DE10E    LH,R13   -1,R6             CHECK REDEFINES BIT                 COBOL21
         BLZ      DE11              YES - DONT SAVE REF NO.             COBOL21
         SLS,R13  -8                LEVEL NUMBER                        COBOL21
         CI,R13   1                                                     COBOL21
         BNE      DE11              NOT 01 LEVEL                        COBOL21
         LH,R6    0,R6                                                  COBOL21
         STW,R6   ORGRN             SAVE 01 REDEFINED REF NO.           COBOL21
DE11     RES      0                                                     COBOL21
         LI,R6    HA(MRC)+1                                             COBOL21
         STH,R3   0,R6                                                  COBOL21
         LI,R3    X'2006'
         AND,R3   PDBCC              BEEN REQUESTED
         BEZ      DE115              NO
         LW,R6    MRC+1             GENERATE A MATCHED REFERENCE
         AI,R6    1                  XRF CLUSTER CONTAINING R#, LINE NO.
         LW,R3    0,R6               OF DEF, AND LINE NO. OF REF
         STW,R3   MRC+1
         LW,R3    CARDNO
         STW,R3   MRC+2
         AI,R6    2
         SLS,R6   1
         LH,R3    0,R6
         LI,R4    BA(MRC)
         BAL,R11  WRXRF             OUTPUT XRF CLUSTER
DE115    BAL,R11  RDEDF
         AI,R2    1
         LB,R3    0,R2
*   NEXT LINE IS A FIX FOR THE NAVY TEST                                COBOL21
         BEZ      DE115             LINE NO CLUSTER                     COBOL21
         CI,R3    X'2B'             LOOK FOR POSSIBLE REDEFINES
         BNE      RD4                QUALIFIER CLUSTERS
         STW,R2   SAV2              ADDRESS OF CLUSTER + 1              COBOL21
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'81'             REDEFINES CLUSTER NOT A QUALIFIER
         BNE      DE115              SHOULD NOT OCCUR HERE
         AI,R2    2                                                     COBOL21
         SLS,R2   -1                POINT TO HA OF I FIELD IN CLUSTER   COBOL21
DE12     AI,R7    -8                BACK UP AN ENTRY IN PDL
         LW,R6    R7
         SLS,R6   -1
         AI,R6    1
         LH,R6    0,R6
         AW,R6    DLORG
         SLS,R6   1
         AI,R6    6
         LH,R3    0,R6              IS R # IN CLUSYER = R # IN DICT     COBOL21
         CH,R3    0,R2
         BE       DE115             YES - LOOK FOR MORE QUALIFIERS
         CI,R7    BA(PDL)
         BNE      DE12
         LI,R1    69
         BAL,R11  DIAG              INCORRECT QUALIFICATION
         LW,R2    SAV2              ADDRESS OF CLUSTER + 1              COBOL21
         B        RD4
LEVER    STW,R7   LEVNUM            USE PREVIOUS LEVEL NO.
         LW,R3    R7                 AND PROCEED
         B        DE1
DETEMP   RES      6
DEEXIT   RES      1
MRC      DATA     X'07020000'       MATCHED REFERENCE CLUSTER
         RES      3                  SKELETON
ORGRN    DATA     0                 ORIGINAL 01 REDEFINED REF NO.       COBOL21
         TITLE    'LEVEL 01 DATA ENTRY CLUSTER PROCESSOR'
         PAGE
L1       AI,R2    -1
         LI,R4    1
         STW,R4   NUL01             SET NOT A NULL SECTION FLAG
         LI,R4    0
         LB,R3    0,R2
         AI,R2    1
         CI,R3    X'23'             IS CURRENT CLUSTER A FILLER
         BE       L10               OR NAMELESS REPORT ENTRY
         CI,R3    X'34'
         BE       L10
         CI,R3    X'36'             NO
         BNE      L11               YES / SET LEV. 01 FILLER FLAG
L10      STW,R2   LEV1FILL
         B        L12
L11      AND,R3   L(X'F')           IS THIS A LABEL RECORD
         BEZ      L12               NO
         STW,R2   LRFLAG            YES - SET LABEL RECORD FLAG
         LW,R3    *DLORG            IS DICT. WORK AREA EMPTY
         BEZ      L20                YES
         BAL,R11  PROCESS
         B        L155
L12      LB,R3    SHFLG
         CI,R3    9
         BL       L15               FILE SECTION
L13      LI,R3    1                 YES - SET LEVEL NO. IN R3
         LW,R5    L77FLG            IS LEV 77 FLAG SET?
         BNEZ     L136               YES
         STW,R3   L1DUP            NO - SET FLAG FOR 1ST POSS. BAD 77
         LW,R5    PDLX             IS PDL EMPTY
         CI,R5    PDL
         BNE      %+4               NO
         STW,R4   FSTWSCS
         MTW,2    PDLX                YES
         B        L15
         LW,R5    *DLORG            IS DICT. WORK AREA EMPTY
         BNEZ     L130               NO
         STW,R4   FSTWSCS           RESET 1ST 01 WS/CS FLAG
         B        L20
L130     LW,R5    FSTWSCS           IS 1ST 01 WS/CS FLAG SET
         BNEZ     L132                 YES - PRECEDING 77S ABSENT
         BAL,R11  REDEF
         LW,R5    L66FLG
         BEZ      L131
         STW,R4   LEVNUM
         BAL,R11  PROCESS
         B        L134
L131     BAL,R11  PROCESS
         B        L133
L132     STW,R4   FSTWSCS
         STW,R4   LEVNUM
         BAL,R11  PROCESS
*    FOLLOWING REMOVED FOR SIDR 26734 10-14-75                          COBOL21
*        BAL,R11  OUTINDX           CHECK DDD SHOULD BE OUT             COBOL21
L1321    LI,R1    8                                                     COBOL21
         CB,R1    SHPREV            WAS PREV. SEC. HDR. A FILE?
         BNE      L133               NO
         LW,R1    DBLINE
         STW,R1   DBLPREV
         LW,R1    DBNTNUM           YES - TERMINATE LAST FILE
         BAL,R11  TERFIL
         LW,R1    LRFLAG
         BEZ      L133
         LW,R1    BASE10DP
         CW,R1    MAXLAB
         BLE      %+2
         STW,R1   MAXLAB
         STW,R4   BASE10DP
         STW,R4   LRFLAG
L133     RES      0                                                     COBOL21
         LW,R1    L66FLG                                                COBOL21
         BNEZ     L134              BEEN TO  VPROC ALREADY              COBOL21
         BAL,R11  VPROC                                                 COBOL21
         B        L134A             SIDR NAVY TEST                      COBOL21
L134     STW,R4   L66FLG
         LB,R3    *DLPNTR      * *  NAVY   QUALIFICATION OF  66 ITEMS   COBOL21
         AW,R3    DLPNTR       * RE-CALCULATATE END OF RANGE  FOR 01    COBOL21
         SW,R3    DLORG        *    TO INCLUDE  66 ITEMS                COBOL21
         LI,R7    5            *                                        COBOL21
         STH,R3   *DLORG,R7    ***  QUALIFICATION  OF  66 ITEMS         COBOL21
         B        L139                                                  COBOL21
L134A    RES      0                                                     COBOL21
         LW,R1    FILFLG
         BEZ      %+2                                                   COBOL21
         BAL,R11  SQUEEZ
         BAL,R11  SYNLNK
         B        L139
L136     STW,R4   FSTWSCS
         CB,R5    SHFLG             IS 77 IN CURRENT SECTION            COBOL21
         BE       %+2               NO SAME SECTION DO NOT RESET        COBOL21
         STW,R4   LEVNUM            SET LEVNUM TO ZERO                  COBOL21
         BAL,R11  PROCESS           PROCESS LAST 77
         LI,R3    1                                                     COBOL21
         STW,R3   LEVNUM            SET LEVNUM TO 1                     COBOL21
         BAL,R11  VPROC             PROCESS VALUES
         BAL,R11  SYNLNK            ESTABLISH SYNONYM LINKAGES
         STW,R4   L77FLG
         BAL,R11  OUTSEG
         B        L14
L139     BAL,R11  OUTSEG            OUTPUT A SEGMENT
         LW,R3    LEVNUM
         BNEZ     L20+4
         LI,R3    1
         STW,R3   LEVNUM
L14      MTW,2    PDLX
         B        L20+4
L15      LW,R3    *DLORG            IS DICT. WORK AREA EMPTY?
         BEZ      L20               YES
         BAL,R11  PROCESS
         LW,R3    LRFLAG            IS LABEL RECORD FLAG SET
         BEZ      L155              NO
         LW,R3    BASE10DP          YES
         CW,R3    MAXLAB            IS CURRENT LAB RCD LARGER THAN PREV
         BLE      %+2               NO
         STW,R3   MAXLAB            YES - UPDATE MAX LAB RCD LENGTH
         STW,R4   BASE10DP          RESET LABEL DISP. COUNTER
         STW,R4   LRFLAG             AND LABEL RCD. FLAG
L155     RES      0                                                     COBOL21
         MTW,0    L66FLG            IS LEV 66 FLAG SET                  COBOL21
         BNEZ     L157              YES--BYPASS VPROC HERE              COBOL21
         BAL,R11  VPROC                                                 COBOL21
         B        L16                                                   COBOL21
L157     RES      0                                                     COBOL21
         STW,R4   L66FLG            YES - RESET IT
         B        L18
L16      LW,R3    FILFLG            IS FILLER FLAG SET?
         BEZ      L17               NO
         BAL,R11  SQUEEZ            REMOVE FILLER ENTIES FROM DICT.
L17      BAL,R11  SYNLNK            ESTABLISH SYNONYM LINKAGES
L18      LW,R3    LRFLAG            IS LABEL RCD. FLAG SET
         BEZ      L185              NO
         LW,R3    DISP              WAS LAST 01 A LABEL RCD.
         BEZ      L19               YES
L185     LW,R3    DISP              IS CURRENT RECORD LARGER THAN
         CW,R3    MRL                ANY PREVIOUS WITHIN FILE?
         BLE      L19               NO
         STW,R3   MRL               YES - SAVE CURRENT LENGTH AS MAX.
L19      BAL,R11  OUTSEG
L20      LI,R3    8                 IF OTHER THAN FILE SECTION,
         CB,R3    SHFLG              DO NOT RESET DISPLACEMENT
         BNE      %+2
         STW,R4   DISP
         LW,R3    DXORG
         SLS,R3   -2
         SW,R3    DLPNTR
         CI,R3    9
         BGE      L201
         LI,R3    X'4000'           DICT. WORK AREA OVERFLOW
         OR,R3    PDBP               FATAL ERROR
         STW,R3   PDBP               SET ABORT FLAG AND TERMINATE
         LI,R1    122
         BAL,R11  DIAG
         B        PH21E
L201     LB,R3    *DLPNTR           BUMP DICT. POINTER
         AWM,R3   DLPNTR
         LI,R3    X'C'              IF REPORT SECTION SET C IN DICT
         CB,R3    SHFLG              TO 26
         BNE      %+3                ELSE A=24
         LI,R3    26
         B        %+2
         LI,R3    24
         STB,R3   *DLPNTR
         LI,R3    1                 LEV. NO. 1 TO PDL AND DICT.
         STB,R3   *PDLX
         LI,R7    8
         STB,R3   *DLPNTR,R7
         LW,R3    LEV1FILL          IS LEV. 01 FILLER FLAG SET
         BEZ      L202               NO
         STW,R4   LEV1FILL           YES - RESET IT
         LI,R3    X'C'
         CB,R3    SHFLG
         BNE      L2015
         LI,R3    -2                NAMELESS RPT ENTRY SET R3#2-2
         B        L204
L2015    LW,R3    CARDNO            REGULAR FILLER
         LW,R5    DLPNTR            MOVE LATWST LINE NO TO
         AI,R5    1                 FILLER DICT.ENTRY
         STW,R3   0,R5
         LI,R3    -1                #2-1
         B        L204
L202     AI,R2    3                 MOVE SOURCE LINE NUMBER AND SUB
         LW,R3    DLPNTR             FROM CLUSTER TO DICT.
         AI,R3    1
         SLS,R3   2
         LI,R5    4
         STB,R5   R3
         MBS,R2   0
         AI,R2    -6                R# TO G OF DICT.
         SLS,R2   -1
         LH,R3    0,R2
L204     LI,R7    6
         STH,R3   *DLPNTR,R7
         LW,R3    LRFLAG            IS THIS A LABEL RECORD?
         BNEZ     L205               YES - SET TYPE TO LABEL
         LB,R3    SHFLG
         CI,R3    X'C'              IS THIS A REPORT RECORD
         BNE      L21                NO - THEREFORE NORMAL RECORD
         LI,R3    4                  YES - SET TYPE TO REPORT
         B        L22
L205     LI,R3    5
         B        L22
L21      RES      0                                                     COBOL21
*        SET H FIELD TO CORRECT TYPE                                    COBOL21
         CI,R3    9                 IS THIS WORKING STORAGE
         BE       L22               YES
         AI,R3    -1
         CI,R3    9
         BGE      L22               LINKAGE OR COMMON-STORAGE
         LI,R3    6                 SET TYPE TO NORMAL RECORD           COBOL21
L22      LI,R7    14
         SLS,R3   4
         STB,R3   *DLPNTR,R7
         LI,R7    4                 GET CURRENT DISPLACEMENT
         LB,R6    SHFLG
         EXU      GETDISP1-8,R6
         AI,R3    3
         LI,R4    X'FFFFC'
         CI,R6    X'C'              IN REPORT SECTION
         BE       %+3                 YES - WORD ALIGN ONLY
         AI,R3    4                   NO - DOUBLE-WORD ALIGN RECORDS
         LI,R4    X'FFFF8'                 IN OTHER SECTIONS
         AND,R3   R4
         EXU      STORDISP-8,R6     SET APPROPRIATE DISPLACEMENT COUNTER
         STW,R3   *DLPNTR,R7
         MTW,0    PDBDBG            SEE COMPILING WITH DEBUG MODE       COBOL21
         BEZ      L225              NO                                  COBOL21
         LI,R4    6                                                     COBOL21
         LH,R7    *DLPNTR,R4                                            COBOL21
         CI,R7    3                 SEE IF THIS IS DEBUG-LINE REF#      COBOL21
         BNE      L225              NO                                  COBOL21
         AWM,R3   PDBDBG            FORM BASE PLUS DISPLACEMENT         COBOL21
L225     RES      0                                                     COBOL21
         LW,R3    LRFLAG            IF LABEL RECORD, SET BASE NO. TO 10
         BEZ      L23                ELSE USE CURRENT BASE NO.
         LI,R3    10
         B        L24
L23      EXU      GETBASE-8,R6      GET CURRENT BASE NO.
L24      LI,R7    16
         STB,R3   *DLPNTR,R7
         CI,R6    8                 IS THIS FILE OR REPORT SECTION?
         BE       L25                YES
         CI,R6    X'C'              IN REPORT SECTION
         BE       L25
         LB,R3    *OCCX              NO - STORE TDB#, IF ANY,
         B        %+2                IN N OF DICT.
L25      LW,R3    DESBNUM           STORE CURRENT DESC. BLOCK NUMBER
         LI,R7    20                 IN DICT.
         STB,R3   *DLPNTR,R7
         LW,R3    DLPNTR            STORE REL. ADDR. OF CURRENT DICT.
         SW,R3    DLORG              ENTRY IN CURRENT PDL ENTRY
         LI,R7    1
         STH,R3   *PDLX,R7
         B        RD2
OUTINDX  STW,R11  OIDXR             SAVE LINKAGE                        COBOL21
         LW,R1    IDXX                                                  COBOL21
         CI,R1    IDXTAB            ANY INDEX ITEM?                     COBOL21
         BE       *OIDXR            NO - RETURN                         COBOL21
         BAL,R11  CKDDDOUT          CHECK IF DDD SHOULD BE OUTPUT       COBOL21
         LW,R8    R3                                                    COBOL21
         XW,R1    R2                                                    COBOL12
         BAL,R11  GENINDX           OUTPUT INDEX ITEM DDD               COBOL21
         XW,R2    R1                                                    COBOL21
         LW,R3    R8                                                    COBOL21
         B        *OIDXR            RETURN                              COBOL21
OIDXR    RES      1                                                     COBOL21
         TITLE    'LEVEL 66 DATA ENTRY CLUSTER PROCESSOR'
         PAGE
L66      LW,R1    L66FLG            IS LEVEL 66 FLAG SET?
         BEZ      L6600              NO
         LI,R1    1
         STW,R1   LEVNUM
         B        L6615
L6600    CI,R7    77
         BE       L660              YES - ERROR
         CI,R7    1
         BNE      L6606
L660     LI,R1    92                LEVEL 66 ILLEGAL FOLLOWING
         BAL,R11  DIAG               LEVEL 77,  OR 01
L6602    BAL,R11  RDEDF             RESUME PROCESSING AT NEXT LEV. 01
         AI,R2    1                 DATA ENTRY DESC. BLOCK, OR
         LB,R3    0,R2               SECTION HEADER
         BEZ      L6602
         CI,R3    X'21'
         BNE      L6604
         AI,R2    2
         LB,R3    0,R2
         CI,R3    1
         BNE      L6602
         AI,R2    3
         B        DE+1
L6604    CI,R3    X'10'
         BLE      M2
         B        L6602
L6606    LI,R1    1
         STW,R1   LEVNUM            PROCESS ALL ENTRIES CURRENTLY
         BAL,R11  PROCESS            IN PDL BEFORE CONTINUING
         STW,R2   L66FLG            SET LEVEL 66 FLAG
         BAL,R11  VPROC
         LW,R3    FILFLG
         BEZ      L661
         BAL,R11  SQUEEZ
L661     BAL,R11  SYNLNK
         B        %+2
L6615    BAL,R11  PROCESS           PROCESS PREVIOUS LEVEL 66 ENTRY
         LB,R3    *DLPNTR           BUILD LEV 66 DICT. ENTRY
         AWM,R3   DLPNTR            UPDATE DLIST POINTER
         LI,R3    24
         STB,R3   *DLPNTR           A=24
         AI,R2    1                 ESTABLISH SYNONYM LINKAGE
         SLS,R2   -1                DINEX(R#) TO SYN LNK OF DICT.
         LW,R4    DXORG
         AH,R4    0,R2
         LW,R5    DLPNTR
         SLS,R5   2
         AI,R5    1
         OR,R5    L(X'3000000')
         MBS,R4   0
         LW,R3    SEGNUM            DICT. RELATIVE ADDRESS AND
         SLS,R3   14                CURRENT SEG # TO DINDEX(R#)
         LW,R5    R4
         LW,R4    DLPNTR
         SW,R4    DLORG
         AW,R3    R4
         LI,R4    13                BA(R3)+1
         AI,R5    -3
         OR,R5    L(X'3000000')
         MBS,R4   0
         LH,R3    0,R2              R# TO DICT.
         LI,R7    6
         STH,R3   *DLPNTR,R7
         AI,R2    1                 MOVE SOURCE LINE NO. AND SUB
         SLS,R2   1                  FROM CLUSTER TO DICT.
         LW,R3    DLPNTR
         AI,R3    1
         SLS,R3   2
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         LI,R3    1
         STB,R3   *PDLX
         LI,R3    66                LEV. NO. TO DICT.
         LI,R7    8
         STB,R3   *DLPNTR,R7
         LB,R3    SHFLG             TYPE TO DICT.
         LI,R7    14                 AND ALSO SET CLASS IN DICT TO AN
         CI,R3    9
         BLE      %+2               FILE, WORKING-STORAGE
         AI,R3    -1
         SLS,R3   4
         AI,R3    1
         STB,R3   *DLPNTR,R7
         LW,R3    DLPNTR            REL. DICT. ADDRESS TO PDL
         SW,R3    DLORG
         LI,R7    1
         STH,R3   *PDLX,R7
L6616    BAL,R11  RDEDF             GET NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         BEZ      L6616
         CI,R3    X'2D'             IS IT RENAMES?
         BE       L662              YES
         LI,R1    104               NO - ERROR
         BAL,R11  DIAG              LEV 66 WITHOUT RENAMES CLAUSE
L6617    CI,R3    X'21'             SEARCH FOR 1ST LEVEL 1 DATA ENTRY,
         BNE      L6618             DESC. BLOCK, OR SECTION HEADER
         AI,R2    2                 CLUSTER AND CONTINUE PROCESSING
         LB,R3    0,R2
         CI,R3    1
         BNE      L6619
         AI,R2    3
         B        DE+1
L6618    CI,R3    X'10'
         BLE      M2
L6619    BAL,R11  RDEDF
         AI,R2    1
         LB,R3    0,R2
         BEZ      L6619
         B        L6617
L662     AI,R2    3
         SLS,R2   -1                SAVE R# OF RENAMES DATA NAME 1
         LH,R6    0,R2               WHILE LOOKING FOR QUALIFIERS
L6621    BAL,R11  RDEDF             OR RENAMES DATA NAME 2
         BLZ      L66EOF1
         AI,R2    1
         LB,R4    0,R2
         BEZ      L6621
         CI,R4    X'2D'
         BNE      L664               NEITHER OF THE ABOVE
         AI,R2    1
         LB,R4    0,R2
         AND,R4   L(X'F')
         BEZ      L665               DATA NAME 2
         BAL,R11  BRT1              BUILD R# TABLE
         B        L671              NON-RENAMES RETURN
         B        L672              RENAMES DATA NAME 2 RETURN
L6625    BAL,R11  SQUAL             SEARCH QUALIFIERS AND RESOLVE
         B        QUALERR           UNRESOLVABLE QUALIFICATION
L663     AND,R6   L(X'3FFF')        COMPUTE DICT. ADDR. OF RESOLVED
         AW,R6    DLORG              DATA NAME 1
         STW,R6   ADRENAME          SAVE DICTIONARY ADDRESS
         AI,R6    4
         LW,R3    0,R6              GET DISP. FOR DATA NAME 1
         AND,R3   L(X'FFFFFF')
         LI,R7    4
         STW,R3   *DLPNTR,R7        STORE DISP. IN LEV 66 DICT. ENTRY
         LB,R1    SHFLG             SAVE DISP. IN R3 FOR LATER
         EXU      GET66BSE-8,R1     GET RELEVANT BASE NO.
         LI,R7    16
         STB,R4   *DLPNTR,R7        BASE NUMBER TO DICT.
         SLS,R6   1                 FETCH SIZE OF DATA NAME 1 AND SAVE
         AI,R6    3                  FOR LATER USE
         LH,R8    0,R6
         LI,R4    X'68'             INSERT BRANCH OP CODE IN FORK
         STB,R4   FORK
FORK     B        0                 GO TO APPROPRIATE NEXT ACTION
L664     LI,R4    L670              ADDRESS TO COMPLETE RENAMES PROC.
         STW,R4   FORK               NO DATA NAME 2 PRESENT
L6645    LW,R4    DXORG             COMPUTE DINDEX ADDRESS
         AW,R4    R6
         LI,R5    25                MOVE DINDEX ENTRY TO BA(R6)+1
         OR,R5    L(X'3000000')
         MBS,R4   0
         B        L663
L665     LI,R4    L666              ADDRESS TO PROCESS DATA NAME 2
         STW,R4   FORK
         B        L6645
L666     AI,R2    3
         SLS,R2   -1                SAVE R# OF RENAMES DATA NAME 2
         LH,R6    0,R2               WHILE LOOKING FOR QUALIFIERS
         BAL,R11  RDEDF
         BLZ      L66EOF2
         AI,R2    1
         LB,R4    0,R2
         CI,R4    X'2D'
         BNE      L669              NO QUALIFIERS - FINISH DATA NAME 2
*   NEXT LINE IS A FIX FOR THE NAVY TEST                                COBOL21
         AI,R2    1                                                     COBOL21
         BAL,R11  BRT1              BUILD R# TABLE
         BAL,R11  SQUAL             ALWAYS NON-RENAMES RETURN,RESLV QUAL
         B        QUALERR           UNRESOLVABLE QUALIFICATION
L667     AND,R6   L(X'3FFF')        COMPUTE DICT. ADDR. OF RESOLVED
         AW,R6    DLORG              DATA NAME 2
         AI,R6    4
         LW,R4    0,R6
         AND,R4   L(X'FFFFFF')      GET DISP. FOR DATA NAME 2
         SLS,R6   1                  ADD TO IT THE SIZE OF DATA NAME 2
         AI,R6    3
         AH,R4    0,R6              SUBTRACT DATA NAME 1 DISP. FROM
         SW,R4    R3                 DATA NAME 2 DISP.
         BGEZ     L668
         LI,R1    71                ERROR
         BAL,R11  DIAG               INCORRECT RENAMES RANGE SPEC.
         B        QUALERR+2
L668     LI,R7    11                STORE RENAMES RANGE IN LEV 66 DICT.
         STH,R4   *DLPNTR,R7         ENTRY SIZE FIELD
         LW,R1    RAHEAD
         BLZ      ENDPH21
         LI,R7    2
         B        L6702
L669     LW,R4    DXORG             COMPUTE DINDEX ADDRESS
         AW,R4    R6
         LI,R5    25                BA(R6)+1
         OR,R5    L(X'3000000')
         MBS,R4   0                 MOVE DINDEX ENTRY TO R6
         B        L667
L670     LI,R7    11                ONLY DATA NAME 1 PRESENT
         STH,R8   *DLPNTR,R7         ITS SIZE IS RENAMES RANGE
*
* INSTRUCTIONS L6700 CHANGE THE IMPLEMENTATION OF RENAMES SO THAT IT
* WOULD ASSUME THE CLASS OF THE ELEMENTARY ITEM BEING RENAMED
* THIS IS DONE IN THE DDD BY MOVING THE CLASS (FIELD I) OF THE
* RENAMED ENTRY INTO THE RENAMES ENTRY
*
L6700    LI,R7    7                 MOVE FIELDS H, I, J, AND K
         LH,R8    -2,R6
         STH,R8   *DLPNTR,R7
         LB,R7    *ADRENAME         MOVE ADDITIONAL FIELDS (IF ANY)
         AI,R7    -6                  I.E., IF MORE THAN 6 WORDS
         BEZ      L67000
         LI,R1    6
         LW,R8    *ADRENAME,R1
         STW,R8   *DLPNTR,R1
         AI,R1    1
         BDR,R7   %-3
         LB,R7    *ADRENAME
         SLS,R7   2
*                                   SUBTRACT 2 BYTES BECAUSE 2 BYTES
*                                   WILL BE ADDED LATER
         AI,R7    -2
         STB,R7   *DLPNTR             STORE NEW SIZE INTO RENAMES ENTRY
L67000   RES      0
*
         LW,R1    RAHEAD
         BLZ      ENDPH21
         LI,R7    2
         B        L6702
L6701    BAL,R11  RDEDF            OBTAIN NEXT LEV1 OR 66 DATA ENTRY,
         BLZ      ENDPH21            DESC. BLOCK, OR SECTION HEADER
         AI,R2    1                  CLUSTER AND CONTINUE PROCESSING
L6702    LB,R3    0,R2
         BEZ      L6701
         CI,R3    X'21'
         BNE      L6703
         AI,R2    2
         LB,R3    0,R2
         CI,R3    1
         BE       %+3
         CI,R3    66
         BNE      L6704
         AI,R2    3
         B        DE+1
L6703    CI,R3    X'10'
         BL       M2
         BE       L6705
L6704    B        %,R7
         B        L6701
         LI,R1    207               EXCESS CLAUSES ON LEVEL 66 DATA
         BAL,R11  DIAG               ENTRY - DISCARDED
         LI,R7    1
         B        L6701
L6705    AI,R2    1
         LB,R4    0,R2
         AND,R4   L(X'F')
         CI,R4    5
         BE       L6701
         AI,R2    -1
         B        M2
REN      LI,R1    72                ERROR - APPEARANCE OF RENAMES
         BAL,R11  DIAG               CLUSTER WITHOUT PRECEDING LEVEL 66.
REN1     BAL,R11  RDEDF              RENAMES DISCARDED
         BLZ      ENDPH21
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'2D'
         BNE      M2
         B        REN1
BRT1     STW,R11  BREXIT            BUILD R NUMBER TABLE
         LCI      3
         STM,R3   BRTEMP                                                COBOL21
         LI,R4    -48                                                   COBOL21
         STW,R6   RNTAB                                                 COBOL21
BRT11    AI,R2    2
         SLS,R2   -1
         LH,R3    0,R2              STORE R NUMBER FROM CURRENT CLUSTER
         STH,R3   RNTAB+25,R4        IN NEXT AVAILABLE RNTAB ENTRY
         BAL,R11  RDEDF             GET NEXT CLUSTER
         BLZ      L66EOFQ
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'2D'             IS IT RENAMES?
         BE       BRT13             YES
BRT12    STW,R4   TABX              SAVE POSITION OF LAST RNTAB ENTRY
         LCI      3                 NO - EXIT1
         LM,R3    BRTEMP                                                COBOL21
         B        *BREXIT
BRT13    AI,R2    1                 IS RENAMES QUALIFIED?
         LB,R3    0,R2
         AND,R3   L(X'F')
         BNEZ     BRT14             YES
         LI,R3    1                 NO - EXIT2
         AWM,R3   BREXIT
         B        BRT12
BRT14    BIR,R4   BRT11
BREXIT   RES      1
BRTEMP   RES      3
TABX     RES      1                 LAST RNTAB ENTRY  (COMPLEMENTED)
SQUAL    LCI      7                 SEARCH OUT QUALIFIERS               COBOL21
         STM,R1   SQTEMP            SAVE REGISTERS                      COBOL21
         LW,R4    TABX              GET COUNT OF DATA NAMES (MOD) 50    COBOL21
         AI,R4    50                GET ACTUAL COUNT OF DATA NAMES      COBOL21
SQ1      BAL,R1   SQMOV             GET RELATIVE POS OF NAMES DICT      COBOL21
         AW,R7    DLORG             GET ACTUAL POS OF DICT ENTRY        COBOL21
         LW,R6    0,R7              GET SYM LINK TO FIND OUT IF         COBOL21
         AND,R6   L(X'FFFFFF')      NAME IS UNIQUE                      COBOL21
         BEZ      SQ2               NAME IS UNIQUE                      COBOL21
         BDR,R4   SQ1               TRY AGAIN                           COBOL21
         B        SQRTX             NO NAMES ARE UNIQUE ERROR           COBOL21
SQ2      LW,R6    2,R7              GET END OF RANGE                    COBOL21
         AND,R6   L(X'FFFFFF')                                          COBOL21
         STW,R6   RANGEH            STORE HIGH RANGE                    COBOL21
         SW,R7    DLORG                                                 COBOL21
         STW,R7   RANGEL            STORE LOW RANGE                     COBOL21
         BDR,R4   SQ3               GET NEXT ITEM IN TABLE              COBOL21
         LW,R6    RANGEL            NONE LEFT PUT RELATIVE ADDR IN R6   COBOL21
         AI,R11   1                 GET READY TO EXIT                   COBOL21
SQRTX    LCI      5                 RESTORE REGISTERS                   COBOL21
         LM,R1    SQTEMP                                                COBOL21
         LW,R7    SQTEMP+6                                              COBOL21
         B        *R11              EXIT                                COBOL21
SQ3      BAL,R1   SQMOV             GET RELATIVE POS OF NAME IN DICT    COBOL21
SQ4      CW,R7    RANGEH            CHECK IF OUTSIDE OF HIGH RANGE      COBOL21
         BGE      SQ5               YES IT IS                           COBOL21
         CW,R7    RANGEL            CHECK IF INSIDE OF LOW RANGE        COBOL21
         BGE      SQ6               YES GOOD                            COBOL21
         B        SQRTX             NO ERROR EXIT                       COBOL21
SQ5      AW,R7    DLORG             GET ACTUAL LOCT IN DICT             COBOL21
         LW,R6    0,R7              GET LINK                            COBOL21
         AND,R6   L(X'FFFFFF')                                          COBOL21
         BEZ      SQRTX             NO LINK ERROR EXIT                  COBOL21
         SLD,R6   -14                                                   COBOL21
         SLS,R7   -18                                                   COBOL21
         CW,R6    SEGNUM            CHECK SEGMENT NO                    COBOL21
         BNE      SQRTX             ERROR EXIT                          COBOL21
         B        SQ4               GO CHECK IF IN RANGE                COBOL21
SQ6      AW,R7    DLORG             GET ACTUAL LOC IN DICT              COBOL21
         LW,R6    0,R7              GET LINK                            COBOL21
         AND,R6   L(X'FFFFFF')                                          COBOL21
         SLS,R6   -14               GET SEG NUMBER                      COBOL21
         CW,R6    SEGNUM                                                COBOL21
         BNE      SQ2                                                   COBOL21
         LW,R6    0,R7              GET LINK                            COBOL21
         AND,R6   L(X'3FFF')                                            COBOL21
         BEZ      SQ2               NO LINK     GOOD                    COBOL21
         CW,R6    RANGEL            CHECK IF LINK IS IN RANGE           COBOL21
         BL       SQ2               NO-----GOOD                         COBOL21
         B        SQRTX             YES----ERROR EXIT                   COBOL21
SQMOV    LH,R2    RNTAB,R4          LOAD HASH NO. OF DATA NAME          COBOL21
         AW,R2    DXORG             ADD INDEX ORIGIN TO GET ADDR        COBOL21
         LI,R3    24                OF RELATIVE DICT LOC                COBOL21
         OR,R3    L(X'3000000')     MOVE TO R6                          COBOL21
         MBS,R2   0                                                     COBOL21
         SLD,R6   -22               PUT RELATIVE DICT ADDR IN R7        COBOL21
         SLS,R7   -18                                                   COBOL21
         CW,R6    SEGNUM            CHECK SEG NO.                       COBOL21
         BNE      SQRTX                                                 COBOL21
         B        *R1                                                   COBOL21
RANGEH   RES      1                                                     COBOL21
RANGEL   RES      1                                                     COBOL21
SQTEMP   RES      7                                                     COBOL21
L671     LI,R4    L670
         STW,R4   FORK
         B        L6625
L672     LI,R4    L666
         STW,R4   FORK
         B        L6625
L66EOF1  STW,R2   RAHEAD
         B        L664
L66EOF2  STW,R2   RAHEAD
         B        L669
L66EOFQ  STW,R2   RAHEAD
         B        BRT12
GET66BSE LW,R4    BASENUM           CURRENT BASE NO.
         LI,R4    1                 WORKING-STORAGE BASE NO.
         LI,R4    X'FF'             LINKAGE BASE NO
         LI,R4    9                 COMMON-STORAGE BASE NO.
QUALERR  LI,R1    69                QUALIFICATION CAN NOT BE RESOLVED
         BAL,R11  DIAG              STORE ASSUMED SIZE OF 1 BYTE IN
         LI,R4    1                  DICT
         B        L668
         TITLE    'LEVEL 77 DATA ENTRY CLUSTER PROCESSOR'
         PAGE
L77      LB,R4    SHFLG
         CI,R4    8                 IS LEVEL 77 IN FILE SECTION
         BNE      L7700             NO
         LI,R1    213               YES - ERROR - DISCARD DATA ENTRY
         BAL,R11  DIAG
L77A1    BAL,R11  RDEDF             RESUME PROCESSING AT NEXT DATA ENTRY
         BLZ      ENDPH21
         AI,R2    1
         LB,R3    0,R2
         BEZ      L77A1
         CI,R3    X'21'
         BE       DE
         CI,R3    X'10'
         BLE      M2
         B        L77A1
L7700    LW,R1    L77FLG            IS LEVELL 77 FLAG SET
         BNEZ     L771               YES - PROCESS PREV. LEVEL 77
         LW,R1    L77DUP            IS THIS 1ST TIME HERE WITHIN SECTION
         BNEZ     L7701
         STW,R2   L77DUP
         LB,R1    SHFLG                                                 COBOL21
         CI,R1    9                                                     COBOL21
         BE       %+3               IN WORKING-STORAGE                  COBOL21
         STW,R1   L77FLG                                                COBOL21
         B        L7703
         LW,R4    L1DUP            TEST FOR 1ST POTENTIAL OUT OF
         BEZ      L7702            SEQUENCE LEV 77 ENTRY
         LI,R4    0
         STW,R4   L1DUP
L7701    LI,R1    91                NO - ERROR - 775 NOT 1ST IN SECTION
         BAL,R11  DIAG
         LI,R3    1                 PROCESS AS 01
         STW,R3   LEVNUM
         B        L1
L7702    RES      0                                                     COBOL21
         STW,R1   L77FLG            SET LEVEL 77 PROCESSING FLAG
         LI,R4    9                                                     COBOL21
         CB,R4    SHFLG
         BE       %+3               IN WK-STORAGE                       COBOL21
L7703    LW,R4    L77TV-2           ALTER L777TV SINCE PRECEDING        COBOL21
         STW,R4   L77TV              ENTRY NOT A 77 IN WORKING-STORAGE
         LW,R4    PDLX
         CI,R4    PDL
         BE       L771-2            PDL EMPTY
         LW,R4    *DLORG
         BEZ      L772              DICT. WORK AREA EMPTY
         LI,R1    0
         STW,R1   LEVNUM            PROCESS ALL ENTRIES CURRENTLY
         BAL,R11  PROCESS            IN PDL BEFORE CONTINUING
         LI,R1    77                                                    COBOL21
         STW,R1   LEVNUM            RESET LEVNUM FOR PROPER CONT        COBOL21
         LI,R1    8
         CB,R1    SHPREV            WAS PREV. SEC. HDR. A FILE HDR.?
         BNE      L77TAD            NO
         LW,R1    DBLINE
         STW,R1   DBLPREV
         LW,R1    DBNTNUM           YES - TERMINATE LAST FILE
         AI,R2    -1                RESTE R2 FOR GENINDX                COBOL21
         BAL,R11  TERFIL
         AI,R2    1                 RESET R2                            COBOL21
         LW,R1    LRFLAG
         BEZ      L77A
         LW,R1    BASE10DP
         CW,R1    MAXLAB
         BLE      %+2
         STW,R1   MAXLAB
         LI,R1    0
         STW,R1   BASE10DP
         STW,R1   LRFLAG
         B        L77A
L77TAD   BAL,R11  OUTINDX                                               COBOL21
L77A     LW,R1    L66FLG
         BEZ      %+4
         LI,R1    0
         STW,R1   L66FLG
         B        L770
         BAL,R11  VPROC
         LW,R1    FILFLG
         BEZ      %+2
         BAL,R11  SQUEEZ
         BAL,R11  SYNLNK
L770     BAL,R11  OUTSEG            OUTPUT LAST FILE SECTION SEGMENT
         LW,R1    PDLX
         CI,R1    PDL
         BNE      %+2
         MTW,2    PDLX
         B        L772
L771     LB,R7    SHFLG
         CW,R7    L77FLG            COMPARE TO PREVIOUS                 COBOL21
         BE       %+2               IF SAME GO PROCESS IT
         STW,R7   L77FLG            OTHERWISE MAKE 77 FLAG CURRENT
         B        %-8,R7
         B        L7713             WORKING-STORAGE
         B        L77TV             LINKAGE                             COBOL21
L77TV    LI,R1    0                 COMMON-STORAGE
         STW,R1   LEVNUM            PRECEDING ENTRY A 77
         BAL,R11  PROCESS            IN WORKING-STORAGE
         LI,R1    77
         STW,R1   LEVNUM
         MTW,2    PDLX
         LW,R7    L77TV-2           WRITE WKOR COMMON                   COBOL21
         STW,R7   L77TV              STORAGE SEGMENT OF LEVEL 77 ENTRIES
         B        L7716              OTHERWISE PROCESS PREV. LEV. 77
L7713    BAL,R11  PROCESS
         LW,R4    DXORG
         SLS,R4   -2
         SW,R4    DLPNTR
         CI,R4    4                 ROOM IN DLAREA FOR NEW ENTRY?
         BGE      L773              YES
L7716    BAL,R11  VPROC             NO - PROCESS VALUES
         BAL,R11  SYNLNK            ESTABLISH SYNONYM LINKAGES
         BAL,R11  OUTSEG            OUTPUT CURRENT SEGMENT
L772     LW,R4    L(X'18000000')    CONSTRUCT LEV 77 DICT. ENTRY
         STW,R4   *DLPNTR           A=24   B=0
         STB,R3   *PDLX
         LI,R7    8                 77 TO LEV NO. IN PDL AND DICT.
         STB,R3   *DLPNTR,R7
         AI,R2    -1
         LB,R3    0,R2
         CI,R3    X'23'             IS DATA ENTRY A FILLER
         BE       L774               YES - ERROR
         AI,R2    4                 MOVE SOURCE LINE NUMBER AND SUB
         LW,R3    DLPNTR             FROM CLUSTER TO DICT.
         AI,R3    1
         SLS,R3   2
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         AI,R2    -6                R# TO G OF DICT.
         SLS,R2   -1
         LH,R3    0,R2
L7725    LI,R7    6
         STH,R3   *DLPNTR,R7
         LB,R3    SHFLG             SET TYPE IN H OF DICT.
         LI,R7    14
         CI,R3    9
         BLE      %+2               FILE, WORKING-STORAGE
         AI,R3    -1
         SLS,R3   4
         STB,R3   *DLPNTR,R7
         LI,R7    15                STORE CURRENT LEVEL OF NESTING
         LCW,R3   OCCX               IN K OF DICT.
         AI,R3    OCCPDL-1
         LCW,R3   R3
         SLS,R3   4
         STB,R3   *DLPNTR,R7
         LI,R7    4                 GET WORKING OR COMMON STORAGE
         LB,R6    SHFLG
         EXU      GETDISP1-8,R6
*  THE FOLLOWING 3 INSTRUCTIONS FORCE 77 ITEMS TO WORD BOUNDARIES
         AI,R3    3                 FORCE 77 ITEM TO THE
         AND,R3   L(X'FFFFFFFC')      NEXT WORD BOUNDARY
         EXU      STORDISP-8,R6       AND STORE THE NEW DISPLACEMENT
*
         STW,R3   *DLPNTR,R7
         LI,R7    16                BASE NUMBER TO L OF DICT.
         EXU      GETBASE-8,R6
         STB,R3   *DLPNTR,R7
         LI,R7    20                TDB#, IF ANY, TO N OF DICT.
         LB,R3    *OCCX
         STB,R3   *DLPNTR,R7
         LW,R3    DLPNTR            STORE RELATIVE ADDRESS OF CURRENT
         SW,R3    DLORG              DICT. ENTRY IN CURRENT PDL ENTRY
         LI,R7    1
         STH,R3   *PDLX,R7
         SLS,R2   1
         AI,R2    -1
         BAL,R11  REDEF
         B        RD2
L773     LB,R4    *DLPNTR           ADD LENGTH OF PREV. DICT. ENTRY
         AWM,R4   DLPNTR             TO DICT. POINTER
         STW,R4   LPDE              STORE LENGTH OF PREV DICT ENTRY
         B        L772
L774     LI,R1    120               FILLER MEANINGLESS ON LEVEL 77 ENTRY
         BAL,R11  DIAG
         LW,R3    CARDNO            MOVE LATEST LINE NO. TO
         LW,R4    DLPNTR             FILLER DICT. ENTRY
         AI,R4    1
         STW,R3   0,R4
         LI,R3    -1                STORE ALL BITS IN R# FIELD OF DICT.
         B        RD2                                                   COBOL21
GETBASE  LW,R3    BASENUM           CURRENT BASE NO.
         LI,R3    1                 WORKING-STORAGE BASE NO.
         LI,R3    X'FF'             LINKAGE BASE NO
         LI,R3    9                 COMMON-STORAGE BASE NO.
         LW,R3    BASENUM           CURRENT BASE NO.
L77TVI   LI,R1    0                 INST FOR L77TV                      COBOL21
         TITLE    'LEVEL 88 DATA ENTRY CLUSTER PROCESSOR'
         PAGE
L88      LW,R4    L88PNTR           IS THIS 1ST 88 FOR CURRENT COND VAR?
         BNEZ     L880               NO
         LW,R4    DLPNTR             YES - SAVE DICT. ADDR. OF COND VAR
         STW,R4   L88PNTR
         STW,R7   LEVNUM            SAVE COND VAR LEVEL NO.
         LB,R4    *DLPNTR           CONVERT COND VAR DICT. LENGTH
         AW,R4    ADDDL             ROOM FOR TRAILING LENGTH
         SLS,R4   -2
         STB,R4   *DLPNTR
L880     LB,R4    *DLPNTR           BUMP DICT. POINTER
         AWM,R4   DLPNTR
         LW,R4    L(X'18000000')    SET INITIAL DICT. LENGTH IN BYTES
         STW,R4   *DLPNTR            CONVERT LATER TO WORDS
         LI,R7    8                 88 TO LEVEL NO. IN DICT.
         STB,R3   *DLPNTR,R7
         AI,R2    3                 C AND D FROM CLUSTER TO DICT.
         LW,R3    DLPNTR
         AI,R3    1
         SLS,R3   2
         LI,R4    4
         STB,R4   R3
         MBS,R2   0
         AI,R2    -6                R# TO DICT.
         SLS,R2   -1
         LH,R3    0,R2
         LI,R7    6
         STH,R3   *DLPNTR,R7
         LW,R4    L88PNTR           COPY H THRU P FIELDS FROM DICT.
         SLS,R4   2                  ENTRY TO WHICH COND. NAME CORRESP.
         AI,R4    14                 INTO LEV 88 DICT. ENTRY
         LW,R5    DLPNTR
         SLS,R5   2
         AI,R5    14
         LI,R6    10
         LI,R7    15                EXAMINE K (NO. OF DIM.) TO DETERMINE
         LB,R8    *L88PNTR,R7        WHETHER Q,R, OR S MUST ALSO BE
         SLS,R8   1                  COPIED.  MULTIPLY NO. OF DIM. BY 2
         BEZ      L881
         AW,R6    R8
L881     STB,R6   R5
         MBS,R4   0
         LI,R7    14
         LB,R3    *L88PNTR,R7       IF CLASS OF CONDITIONAL VARIABLE
         AND,R3   L(X'F')            IS NON-ZERO AND
         BEZ      L8815
         CI,R3    5                  IS LESS THAN 6, SET CLASS OF
         BG       L8815              CONDITION NAME VARIABLE TO 1 (AN)
         LB,R3    *DLPNTR,R7
         AI,R3    1
         STB,R3   *DLPNTR,R7
L8815    BAL,R11  RDEDF             GET NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'2E'             IS IT A VALUE CLUSTER?
         BE       L882              YES
         CI,R3    0                 IS IT A LINE NUMBER CLUSTER?
         BE       L8815              YES - READ NEXT CLUSTER
         LI,R1    73                NO - ERROR
         BAL,R11  DIAG              COND. NAME WITHOUT SUCCEEDING VALUE.
         LI,R4    0                  COND. NAME DICT. ENTRY DISCARDED
         LW,R5    DLPNTR                                                COBOL21
         SW,R5    L88PNTR           SIZE FOR ZERO BDR LOOP              COBOL21
         LB,R7    *L88PNTR          LENGTH OF LAST ENTRY                COBOL21
         AW,R7    L88PNTR           ADDR OF FIRST 88 ENTRY              COBOL21
         STW,R7   DLPNTR            ADDR FOR BDR LOOP                   COBOL21
         STW,R4   *DLPNTR,R5
         BDR,R5   %-1
         STW,R4   *DLPNTR
         LW,R5    L88PNTR
         STW,R5   DLPNTR
         B        M2
L882     AI,R2    3
         LB,R3    0,R2              MULTIPLY NO. OF LITERALS FROM
         SLS,R3   2                  VALUE CLAUSE BY 4
         LB,R4    *DLPNTR           GET CURRENT DICT. LENGTH
         AW,R4    R3                 UPDATE IT
         AW,R4    R8
         AW,R4    ADDDL             ROOM FOR TRAILING LENGTH
         SLS,R4   -2                 CONVERT TO WORDS
         STB,R4   *DLPNTR            STORE UPDATED WORD LENGTH
         AW,R4    DLPNTR
         SW,R4    DLORG             STORE END OF RANGE IN F OF DICT.
         LW,R5    L(X'FFFFFF')
         LI,R7    2
         STS,R4   *DLPNTR,R7
         AI,R2    -2
         SLS,R2   -1
         LH,R3    0,R2              GET VALUE SEQ. NO. AND STORE
         AWM,R3   *DLPNTR            TEMPORARILY IN SYN LINK OF DICT.
         LI,R7    6                 SET LEV 88 BIT IN PDL ENTRY CORRESP.
         LB,R3    *PDLX,R7           TO PREVIOUS DICT. ENTRY
         OR,R3    L(X'4')
         STB,R3   *PDLX,R7
         LI,R7    2                 SET FIRST TIME BRANCH
L883     BAL,R11  RDEDF             GET NEXT CLUSTER
         BLZ      ENDPH21
         AI,R2    1
         LB,R3    0,R2              IS IT A SECTION HEADER, DESC. BLOCK,
         CI,R3    X'22'              OR DATA ENTRY?
         BL       M2                YES - EXIT
         CI,R3    X'23'             IS IT A FILLER?
         BE       M2                 YES
         B        %,R7
         B        L883
         LI,R1    74                NO - ERROR
         BAL,R11  DIAG               ADDITIONAL CLAUSES OTHER THAN VALUE
         LI,R7    1                  ON LEV 88 - EXCESS DISCARDED
         B        L883               SET BRANCH TO BYPASS ERROR
         TITLE    'REDEFINES CLUSTER PROCESSOR'
         PAGE
RED      RES      0
RNN      LI,R1    75                MISPLACED REDEFINES CLAUSE.
         BAL,R11  DIAG               SHOULD NOT BE ENCOUNTERED ON MAIN
         B        M1                 TRANSFER VECTOR  -  CLAUSE IGNORED
*        THE FOLLOWING ROUTINE IS USED WHEN IT IS NECESSARY TO          COBOL21
*        DO A READ AHEAD FOR THE EDF CLUSTER                            COBOL21
*        IT WILL STORE THE ACTUAL CLUSTER (IN RAHEADC) AND THE          COBOL21
*        ADDRESS OF RAHEADC + 1 (ADDRESS OF CONTROL BYTE) IN RAHEAD     COBOL21
SAVEDF   RES      0                                                     COBOL21
         STW,R2   SAV2              SAVE R2                             COBOL21
         STW,R3   SAV3              SAVE R3                             COBOL21
         STW,R4   SAV4              SAVE R4                             COBOL21
         AI,R2    -1                POINT TO START OF CLUSTER           COBOL21
         LI,R3    BA(RAHEADC)       DESTINATION ADDRESS                 COBOL21
         LB,R4    0,R2              HALF WORD SIZE                      COBOL21
         SLS,R4   1                 BYTE SIZE                           COBOL21
         STB,R4   R3                STORE SIZE                          COBOL21
         MBS,R2   0                 MOVE CLUSTER                        COBOL21
         LW,R4    RAP1                                                  COBOL21
         STW,R4   RAHEAD            ADDRESS OF SAVED CLUSTER PLUS 1     COBOL21
         LW,R2    SAV2              RESTORE REGISTORS                   COBOL21
         LW,R3    SAV3              RESTORE REGISTORS                   COBOL21
         LW,R4    SAV4              RESTORE REGISTORS                   COBOL21
         B        *R11              RETURN                              COBOL21
         TITLE    'OCCURS CLUSTER PROCESSOR'
         PAGE
OCC      AI,R2    1
         SLS,R2   -1
         LH,R3    0,R2              GET NO. OF OCCURRENCES
         BAL,R11  RDEDF             GET NEXT CLUSTER
         BLZ      OCC7              END OF FILE
         AI,R2    1
         LB,R4    0,R2
         BEZ      %-4
         CI,R4    X'25'             IS IT ANOTHER OCCURS?
         BNE      OCC1              NO
         AI,R2    1                 YES - GET NO. OF OCCURRENCES FROM
         SLS,R2   -1                 CLUSTER WHICH REPRESENTS THE
         LH,R3    0,R2               MAX. NO. OF OCC.
         STW,R3   MAXOCC            SAVE FOR POSSIBLE OCC DEP ON
         B        OCC2
OCC1     BAL,R11  SAVEDF                                                COBOL21
OCC2     LI,R4    OCCPDL            IS THE CURRENT LEVEL OF NESTING
         LCW,R4   R4                 GREATER THAN 3?
         AW,R4    OCCX
         CI,R4    1
         BG       OCC4              YES - ERROR
         AI,R4    2                 NO - STORE CURRENT LEVEL OF NESTING
         LI,R7    15                 IN K OF DICT.
         STB,R4   *DLPNTR,R7
         CI,R4    1                 IS THIS 1ST LEV. OF OCCURS NESTING?
         BNE      OCC8               NO
         SCS,R4   -7                ADD (2 * LEV. OF NESTING) TO LENGTH
OCC25    AWM,R4   *DLPNTR            OF DICT. ENTRY
         LI,R7    1                 SET OCCURS BIT IN CURRENT PDL ENTRY
         LI,R4    X'100'
         OR,R4    *PDLX,R7
         STW,R4   *PDLX,R7
         AWM,R7   OCCX              BUMP OCCPDL POINTER AND STORE THE
         STW,R3   *OCCX              NO. OF OCC. IN CURRENT OCCPDL ENTRY
         LW,R3    RAHEAD            IS READ AHEAD FLAG SET?
         BLZ      ENDPH21
         BNEZ     OCC5              YES
         B        M1                NO - EXIT
ODO      AI,R2    1                 OCCURS DEPENDING ON
         LB,R4    0,R2              GET TDB#
         STB,R4   *OCCX              STORE IN CURRENT OCCPDL ENTRY
         LI,R7    20                 AND N FIELD OF CURRENT DICT. ENTRY
         STB,R4   *DLPNTR,R7
         LI,R3    OCCPDL            IS OCCURS DEPENDING ON WITHIN THE
         SW,R3    OCCX               SCOPE OF ANOTHER OCCURS?
         BLZ      OCC3              YES - ERROR
*        SIDR SIG7-2240                                                 COBOL21
*        CODE WAS LW,R3 ODOFLG   BEZ  OCC6                              COBOL21
*        FLAG WAS SET TO 0 AT LABEL L1                                  COBOL21
*        FLAG WAS SET AT OCC6 WITH STW,R2 ODOFLG  B  M1                 COBOL21
*        ODOFLG WAS A DATA 0 ITEM                                       COBOL21
         B         M1               READ EDF  S94R 2240                 COBOL21
OCC3     LI,R1    76                IF NOT, SET ODOFLG, OTHERWISE ERROR
         BAL,R11  DIAG               ILLEGAL OCCURS DEPENDING ON USAGE
         B        M1
OCC4     LI,R1    77                LEVEL OF OCCURS NESTING
         BAL,R11  DIAG               GREATER THAN 3
         LW,R3    RAHEAD            IS READ AHEAD FLAG SET?
         BEZ      M1                 NO - EXIT
         BLZ      ENDPH21
OCC5     RES      0                                                     COBOL21
         LW,R2    RAHEAD            RESTORE R2 WITH ADDRESS OF CTRL BYTECOBOL21
         LB,R3    0,R2              PICK UP CONTROL BYTE                COBOL21
         LI,R4    0                 RESTE RAHEAD                        COBOL21
         STW,R4   RAHEAD
         B        M2
OCC7     STW,R2   RAHEAD            SET RAHEAD TO END OF FILE
         B        OCC2
OCC8     LW,R4    L(X'2000000')     NOT 1ST LEV. OF OCCURS NESTING
         B        OCC25             ADD 2 TO DICT. LENGTH
OCT      LI,R1    78
         BAL,R11  DIAG              MISPLACED OCCURS CLAUSE - IGNORED
         B        M1
MAXOCC   RES      1
         TITLE    'INDEXED BY CLUSTER PROCESSOR'
         PAGE
IDX      AI,R2    2                 GENERATE AN INDEX TABLE ENTRY
         LB,R3    0,R2              STORE TDB NO. IN CURRENT INDEX TABLE
         STB,R3   *IDXX              ENTRY AND CURRENT OCCPDL ENTRY
         STB,R3   *OCCX
         LI,R7    20                 AND N FIELD OF CURRENT DICT. ENTRY
         STB,R3   *DLPNTR,R7
         LI,R7    1                 STORE R NO. IN IDXTAB
         AI,R2    1
         SLS,R2   -1
         LH,R3    0,R2
         STH,R3   *IDXX,R7
         LW,R4    *DLPNTR,R7        STORE SOURCE LINE NO. AND SUB
         STW,R4   *IDXX,R7           FROM DICT. INTO IDXTAB
         MTW,2    IDXX              BUMP IDXTAB POINTER
         LI,R5    0                 UNCONDITIONALLY RESET
         STW,R5   RAHEAD             READ AHEAD FLAG
         LI,R5    X'2006'           DMAP AND/OR XREF
         AND,R5   PDBCC              BEEN REQUESTED?
         BEZ      M1                 NO - EXIT
         LW,R12   L(X'05010000')     YES - CONSTRUCT A DATA DEFINITION
         AW,R12   R3                 CLUSTER FOR THE INDEX NAME
         LW,R13   R4
         LI,R4    48                BA(R12)
         BAL,R11  WRXRF             OUTPUT IT
         B        M1
         TITLE    'KEY CLUSTER PROCESSOR'
         PAGE
AKY      LI,R6    0                 SET ASCENDING INDICATOR
         B        KY1
DKY      LI,R6    1                 SET DESCENDING INDICATOR
KY1      AI,R2    3
         SLS,R2   -1
         LH,R3    0,R2
         LI,R7    6                 IS R# IN KEY CLUSTER EQUAL TO
         CH,R3    *DLPNTR,R7         R# IN CURRENT DICT. ENTRY?
         BE       KY7               YES
         LI,R7    1                 NO - SET KEY BIT IN CURRENT
         LI,R4    X'800'             PDL ENTRY
         OR,R4    *PDLX,R7
         STW,R4   *PDLX,R7
         LI,R5    1                 INITIALIZE KEY NUMBER COUNTER
         SLS,R2   1
         AI,R2    -1
         LB,R1    0,R2              GET TDB# FROM CLUSTER AND
         STB,R1   *OCCX              STORE IN CURRENT OCCPDL ENTRY
KY2      LW,R4    R5                MAKE KEY TABLE ENTRY CONTAINING
         CI,R6    0                  R#, ORDER INDICATOR, AND KEY NO.
         BE       KY3
         AI,R4    X'80'
KY3      STW,R4   KEYTAB-1,R5
         SLS,R5   1
         STH,R3   KEYTAB-1,R5
         BAL,R11  RDEDF             READ NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         BEZ      %-3
         CI,R3    X'27'             IS IT A KEY?
         BE       KY4
         CI,R3    X'28'
         BE       KY5               YES
         BAL,R11  SAVEDF                                                COBOL21
         B        M2
KY4      LI,R6    0
         B        KY6
KY5      LI,R6    1
KY6      AI,R2    3                 GET R# FROM LATEST CLUSTER
         SLS,R2   -1
         LH,R3    0,R2
         SLS,R5   -1
         AI,R5    1                 BUMP KEY NUMBER COUNTER
         B        KY2
KY7      SLS,R2   1                 KEY NAME SAME AS CURRENT DATA ENTRY
         AI,R2    -1
         LB,R1    0,R2
         LI,R7    20
         STB,R1   *DLPNTR,R7        STORE TDB# IN CURRENT DICT. ENTRY
         LI,R4    1
         CI,R6    0
         BE       KY8
         AI,R4    X'80'
KY8      LI,R7    21                STORE KEY NO. AND ORDER INDICATOR
         STB,R4   *DLPNTR,R7         IN CURRENT DICT. ENTRY
KY9      BAL,R11  RDEDF             READ NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'27'             IS IT A KEY?
         BE       KY10
         CI,R3    X'28'
         BE       KY10              YES - ERROR
         BAL,R11  SAVEDF                                                COBOL21
         B        M2
KY10     LI,R1    101
         BAL,R11  DIAG              UNDEFINED TABLE KEY
         B        KY9
         TITLE    'REPORT SPECIFICATIONS CLUSTER PROCESSOR'
         PAGE
RSPEC    AI,R2    2
         LB,R3    0,R2              GET INTEGER VALUE
         AI,R2    -1
         LB,R4    0,R2              GET TYPE CODE
         BEZ      RSPEC1            COLUMN NUMBER
         STW,R3   RGRPRNO           REPORT GROUP REFERENCE NUMBER
         LI,R5    25                STORE IN R OF DICT.
         STB,R3   *DLPNTR,R5
         B        M1
RSPEC1   LI,R5    24                STORE COLUMN NUMBER IN Q FIELD OF
         STB,R3   *DLPNTR,R5         CURRENT DICT. ENTRY
         STH,R3   OVERLAP           SAVE COLUMN NO.                     COBOL21
         LW,R3    DLPNTR            SAVE DDD POINTER FOR CHECK EL30974  COBOL21
         STW,R3   PREDDD             OVERLAP RPT LINE LATER    EL30974  COBOL21
         B        M1
         TITLE    'BEGINNING OF LINE IMAGE CLUSTER PROCESSOR'
         PAGE
BEGLI    LW,R4    DISP              SAVE CURRENT WORD ADJUSTED DISP.
         AI,R4    3                  IN REPORT LINE DISP.
         AND,R4   L(X'FFFFFFFC')
         STW,R4   DISP
         STW,R4   RLINEDSP
         LW,R4    DLPNTR            COMPUTE ADDRESS OF CURRENT DICT.
         AI,R4    4                  BASE AND DISP. FIELD
         LI,R5    1
         CW,R5    LEVNUM            IS CURRENT DATA ENTRY LEVEL 01
         BE       BEG1               YES
         LW,R5    0,R4               NO - STORE CURRENT DISP. IN DICT.
         AND,R5   L(X'FF000000')
         AW,R5    DISP
         STW,R5   0,R4
         B        BEG2
BEG1     LW,R3    0,R4              LEVEL 01 - ADJUST DISP. IN DICT.
         AI,R3    3                  TO NEXT WORD BOUNDARY
         AND,R3   L(X'FFFFFFFC')
         STW,R3   0,R4
BEG2     SLS,R4   2                 MOVE BASE AND DISP. ALSO TO
         LI,R5    BA(RLINEBUF)+2     REPORT PRINT LINE BUFFER
         LI,R6    4
         STB,R6   R5
         MBS,R4   0
         LI,R1    BA(RLINEBUF)+7    INITIALIZE REPORT LINE BUFFER
         LI,R3    134                TO BLANKS
         STB,R3   R1
         MBS,0    BA(FCCHAR)+1
         AWM,R3   DISP              BUMP DISP. BY LENGTH OF LINE IMAGE
         B        M1
RLINEBUF DATA     X'472D0000'
         DATA     X'00008600'
         RES      34
         TITLE    'END OF LINE IMAGE CLUSTER PROCESSOR'
         PAGE
ENDLI    BAL,R11  RDEDF             GET NEXT CLUSTER
         AI,R2    1
         LB,R3    0,R2
         CI,R3    X'31'             IS IT BEGINNING OF LINE IMAGE
         BE       ENDLI2            YES
         BAL,R11  PRVAL             NO - PROCESS LAST VALUE OF REPORT
ENDLI2   LI,R4    BA(RLINEBUF)      OUTPUT CURRENT REPORT LINE IMAGE
         BAL,R11  WRPOF
         LI,R4    0                 RESET OVERLAP DETECTER
         STW,R4   OVERLAP
         B        M2
         TITLE    'GROUP INDICATE/SUM CLUSTER PROCESSOR'
         PAGE
GISUM    STW,R2   GISUMFLG          SET GROUP INDICATE/SUM FLAG
         LI,R3    0
         CW,R3    SUMFLG            IS SUM FLAG SET
         BE       GIS1              NO
         STW,R3   SUMFLG            YES-RESET IT
         CW,R3    RPTDEADR          DID A NAMED RPT ENTRY PRECEDE SUM
         BE       GIS1              NO-NOT IMMEDIATELY PRECEDING
         LI,R7    6                 YES-GET R# FROM NAMED REPORT
         LH,R3    *RPTDEADR,R7      ENTRY AND STORE IN R# FIELD OF SUM
         STH,R3   *DLPNTR,R7        COUNTER DICT. ENTRY WHICH FOLLOWS
         LI,R3    -2                CHANGE NAMED REPORT ENTRY
         STH,R3   *RPTDEADR,R7      TO NAMELESS
         LI,R7    1                 MOVE LINE NO. AND SUB TO
         LW,R3    *RPTDEADR,R7      OFF LINE SUM COUNTER
         STW,R3   *DLPNTR,R7                                            COBOL21
GIS1     LI,R7    4                 REPLACE REPORT LINE DISP.
         LW,R3    *DLPNTR,R7         CURRENTLY IN DICT. WITH
         AND,R3   L(X'FF000000')     CURRENT DISP.
         AW,R3    DISP
         STW,R3   *DLPNTR,R7
         B        M1
         TITLE    'END OF REPORT ENTRY CLUSTER PROCESSOR'
         PAGE
ERE      LH,R3    OVERLAP           GET COLUMN NO.                      COBOL21
         BEZ      M1                JUMP TO GET NXT CLSTR IF NO COLUMN  COBOL21
         LI,7     1                                                     COBOL21
         CH,R3    OVERLAP,R7        CURRENT ENTRY OVERLAP PREVIOUS ?    COBOL21
         BGE      ERE1              NO                                  COBOL21
         LI,R1    -123               YES - INFORM AND PROCEED
         BAL,R11  DIAG
ERE1     LI,R7    11                                                    COBOL21
         AH,R3    *PREDDD,R7        ADD DATA ENTRY SIZE TO COL EL30974  COBOL21
         STW,R3   OVERLAP            AND SAVE FOR NEXT OVERLAP CHECK
         B        M1
         TITLE    'PROCESS'
         PAGE
PROCESS  STW,R11  PREXIT
         LCI      7                 SAVE REGISTERS
         STM,R1   PRTEMP
         LW,R3    L88PNTR           IS MOST RECENT DICT. ENTRY AN 88?
         BEZ      %+3                NO
         XW,R3    DLPNTR             YES - RESET DICT. PNTR. TO COND VAR
         STW,R3   L88PNTR            ENTRY AND SAVE MOST RECENT DICT. AD
         LW,R3    PICSAVCT          ANY PICTURE INFO. FOR DICT.?
         BEZ      PR1
         LI,R4    0
         STW,R4   PICSAVCT
         LI,R4    BA(PICSAV)        YES - MOVE PICTURE INFO. FROM
         LW,R5    DLPNTR             PICSAV TO DICT.
         AI,R5    6                 STARTING LOCATION FOR PICTURE INFO.
         SLS,R5   2                  IS DICT. ADDRESS + 6 + SPACE
         LI,R7    X'C'                FOR REPORT INFORMATION
         CB,R7    SHFLG              IF IN REPORT SECTION
         BNE      PR00              JUMP IF NOT IN REPORT SECTION       COBOL21
         LI,R6    2                                                     COBOL21
         CI,R3    2                                                     COBOL21
         BNE      PR0               JUMP IF EDITING REPORT LINE         COBOL21
         LB,R7    0,R5          GET COLUMN NO. IF NOT SUM COUNTER       COBOL21
         CI,R7    0                                                     COBOL21
         BNE      PR0           JUMP IF NOT SUM COUNTER (COL NOT 0)     COBOL21
         STB,R3   R5                                                    COBOL21
         MBS,R4   0                 MOVE POINT LOCATION                 COBOL21
         AI,R4    -2                                                    COBOL21
         B        PR01                                                  CCOBOL21
PR00     LI,R7    3                                                     COBOL21
         LI,R6    X'F'
         AND,R6   *DLPNTR,R7
         SLS,R6   1
PR0      AW,R5    R6
PR01     STB,R3   R5                                                    COBOL21
         MBS,R4   0
PR1      LW,R2    L88PNTR
         BNEZ     PR2
         LB,R2    *DLPNTR
         AW,R2    ADDDL             ROOM FOR TRAILING LENGTH
         SLS,R2   -2
         STB,R2   *DLPNTR
PR2      LW,R4    LEVNUM            IS CURRENT ITEM TO BE PROCESSED
         CB,R4    *PDLX              ELEMENTARY?
         BLE      PR4               YES
         STW,R4   GIFLG             NO - SET GROUP INDICATOR FLAG
         LH,R3    *PDLX             DOES CURRENT ITEM HAVE USAGE CLAUSE?
         AND,R3   L(X'FC')
         BEZ      PR7               NO
         LW,R4    GRPUSG            YES - IS GROUP USAGE SET?
         BNEZ     PR3               YES
         STW,R3   GRPUSG            NO - STORE CURRENT USAGE IN GRPUSG
         B        PR7
PR3      CW,R3    GRPUSG            IS GROUP USAGE SAME AS CURRENT?
         BE       PR7               YES
         LI,R1    -79                NO - ERROR - USAGE CONFLICT
         BAL,R11  DIAG
         B        PR7
PR4      LI,R2    0                 ELEMENTARY ITEM
         STW,R2   GIFLG             RESET GROUP INDICATOR FLAG
         LH,R3    *PDLX             IS THERE USAGE ON CURRENT ITEM?
         AND,R3   L(X'FC')
         BNEZ     PR8               YES
         LW,R4    GRPUSG            NO - IS GROUP USAGE SET?
         BNEZ     PR9               YES
         LH,R3    *PDLX             NO - SET CURRENT ITEM USAGE
         OR,R3    L(X'80')           TO DISPLAY
         STH,R3   *PDLX
PR5      LI,R5    14                IS CLASS IN CURRENT DICT. ENTRY SET?
         LB,R6    *DLPNTR,R5
         AND,R6   L(X'F')
         BEZ      PR10              NO
         LH,R3    *PDLX             YES - IS CURRENT ITEM USAGE DISPLAY?
         AND,R3   L(X'80')
         BNEZ     PR7               YES - DISCARD USAGE
         LH,R3    *PDLX
         AND,R3   L(X'74')          NO-IS USAGE COMP,C1,C2, OR INDEX?
         BEZ      PR6               NO - USAGE IS, BY DEFAULT, COMP-3
         LI,R1    -80               YES - ERROR - PICTURE CLAUSE INVALID
         BAL,R11  DIAG               ON FIXED FORMAT ITEM
         LB,R6     *DLPNTR,R5       SECTION AND TYPE                    COBOL21
         AND,R6    L(X'F0')        REMOVE CURRENT USAGE TYPE            COBOL21
         STB,R6    *DLPNTR,R5       PUT SECTION BACK IN                 COBOL21
         B         PR10            PICK UP GROUP USAGE                  COBOL21
PR6      CI,R6    6                 IS CURRENT DICT. CLASS
         BE       %+6                NUMERIC DISPLAY SIGNED
         CI,R6    7                  OR UNSIGNED?
         BE       %+4                YES
         LI,R1    -110               NO - PICTURE CLASS NOT COMPATIBLE
         BAL,R11  DIAG               WITH USAGE COMP-3 (USE PICT. CLASS)
         B        PR7
         LB,R6    *DLPNTR,R5
         AI,R6    2                 ALTER CLASS IN DICT. TO
         STB,R6   *DLPNTR,R5         PACKED DECIMAL SIGNED OR UNSIGNED
PR7      LI,R3    X'20000'          IS THERE BLANK WHEN ZERO CLAUSE
         AND,R3   *PDLX              ON CURRENT ITEM?
         BEZ      PR15              NO
         LW,R3    GIFLG             YES - IS ITEM ELEMENTARY?
         BNEZ     PR13              NO - ERROR
         CI,R6    5                 IS CLASS NUMERIC EDITED?
         BE       PR14              YES
         CI,R6    7                 IS CLASS NUMERIC DISPLAY UNSIGNED?
         BNE      PR13              NO-ERROR
         AI,R6    -2                ALTER CLASS IN DICT. TO
         STB,R6   *DLPNTR,R5         NUMERIC EDITED
         B        PR14
PR8      LW,R3    GRPUSG            USAGE ON CURRENT ELEM. ITEM
         BEZ      PR5               NO GROUP USAGE
         LH,R3    *PDLX             IS CURRENT ELEM. USAGE SAME AS GROUP
         AND,R3   L(X'FC')
         CW,R3    GRPUSG
         BE       PR5               YES
         LI,R1    -79
         BAL,R11  DIAG              NO-ERROR-USAGE CONFLICT
PR9      LI,R4    1                 STORE GROUP USAGE IN CURRENT
         LW,R3    GRPUSG             ITEM USAGE
         STB,R3   *PDLX,R4
         B        PR5
PR10     LH,R8    *PDLX             SET CLASS APPROPRIATE TO
         AND,R8   L(X'FC')           DECLARED USAGE
         LI,R4    X'80'
         LI,R7    6
PR11     LW,R3    R8
         AND,R3   R4
         BNEZ     PR12
         SLS,R4   -1
         BDR,R7   PR11
PR12     LB,R3    *DLPNTR,R5
         OR,R3    CLASSTAB-1,R7
         STB,R3   *DLPNTR,R5
*       THE FOLLOWING WILL FORCE SIZES FOR COMP, COMP-1, COMP-2         COBOL21
         LI,R4    4                 COMP  AND  COMP-1                   COBOL21
         LI,R3    11                INDEX                               COBOL21
         CI,R7    5                 COMP                                COBOL21
         BNE      %+3                                                   COBOL21
         STH,R4   *DLPNTR,R3                                            COBOL21
         B        PR7                                                   COBOL21
         CI,R7    4                 COMP-1                              COBOL21
         BNE      %+3                                                   COBOL21
         STH,R4   *DLPNTR,R3                                            COBOL21
         B        PR7                                                   COBOL21
         CI,R7    3                                                     COBOL21
         BNE      PR7                                                   COBOL21
         LI,R4    8                 COMP-2                              COBOL21
         STH,R4   *DLPNTR,R3                                            COBOL21
         B        PR7
CLASSTAB DATA     X'C'              INDEX
         DATA     9                 NUMERIC PACKED DECIMAL UNSIGNED
         DATA     X'F'              FLOATING-POINT, DOUBLE PRECISION
         DATA     X'E'              FLOATING-POINT, SINGLE PRECISION
         DATA     X'D'              BINARY
         DATA     1                 ALPHANUMERIC
PR13     LI,R1    -81
         BAL,R11  DIAG              INCORRECT USE OF B.W.Z.
         B        PR15
PR14     LI,R7    X'C'              IS IN REPORT SECTION
         CB,R7    SHFLG
         BNE      PR143             NO
         LI,R7    30
         B        PR146
PR143    LI,R7    15
         LB,R7    *DLPNTR,R7
         SLS,R7   1
         AI,R7    28
PR146    LB,R3    *DLPNTR,R7        MODIFY TYPE OF REPLACEMENT IN DICT.
         OR,R3    L(X'8')            (TG FEILD) TO REFLECT  BWZ
         STB,R3   *DLPNTR,R7
PR15     LI,R3    X'10000'          JUSTIFIED RIGHT CLAUSE?
         AND,R3   *PDLX
         BEZ      PR18              NO
         LW,R3    GIFLG             YES - IS ITEM ELEMENTARY?
         BNEZ     PR16              NO - ERROR
         CI,R6    1                 IS CLASS ALPHNUMERIC?
         BE       PR17              YES
         CI,R6    3                 IS CLASS ALPHANUMERIC EDITED?
         BE       PR17              YES
PR16     LI,R1    -82                NO - ERROR
         BAL,R11  DIAG              INCORRECT USE OF J.R.
         B        PR18
PR17     MTB,1    *DLPNTR,R5        MODIFY CLASS FOR JUSTIFICATION
PR18     LI,R7    7                 VALUE CLAUSE?
         LB,R3    *PDLX,R7
         BEZ      PR25              NO
         LW,R3    OCCX              IS VALUE CLAUSE WITHIN SCOPE
         CI,R3    OCCPDL-1           OF OCCURS
         BE       PR185              NO
         LI,R1    -215               YES - ERROR
         BAL,R11  DIAG
PR185    LW,R3    SHFLG
         CI,R3    8                 IS PROCESSING IN FILE SECTION?
         BE       PR25              YES - VALUE CLAUSE IGNORED
         LW,R4    PDLX
PR19     BAL,R11  PR40              SEARCH THROUGH ENTRIES IN PDL
         BNEZ     PR20               LOOKING FOR NON-ZERO RDISP FIELD.
         CI,R4    PDL                IF ONE FOUND, ERROR - VALUE CLAUSE
         BE       PR25              WITHIN SCOPE OF REDEFINES
         AI,R4    -2
         B        PR19
PR20     LI,R1    -83
         BAL,R11  DIAG
PR25     LI,R7    1                 OCCURS DEPENDING ON CLAUSE?
         LI,R3    X'200'
         AND,R3   *PDLX,R7
         BEZ      PR28              NO
         LW,R4    PDLX               WITHIN SCOPE OF REDEFINES.
PR26     BAL,R11  PR40              IF SO, ERROR
         BNEZ     PR27
         CI,R4    PDL
         BE       PR285
         AI,R4    -2
         B        PR26
PR27     LI,R1    -86
         BAL,R11  DIAG
PR28     LW,R3    OCCX              WITHIN RANGE OF OCCURS
         CI,R3    OCCPDL-1
         BE       PR285              NO
         LB,R3    *PDLX             CHECK FOR LEVEL 01 OR 77 ON MOST
         CI,R3    1                  RECENT PDL ENTRY
         BE       PR281
         CI,R3    77
         BNE      PR282
PR281    LI,R1    -216              OCCURS ILLEGAL ON LEVEL 01 OR 77
         BAL,R11  DIAG
PR282    LH,R3    *PDLX             IS USAGE COMP, COMP-1, COMP-2
         AND,R3   L(X'74')           OR INDEX
         BEZ      PR285              NO
         LI,R1    1
         LH,R3    *PDLX              YES - IS USAGE COMP-2
         AND,R3   L(X'10')
         BNEZ     PR283               YES
         LB,R3    *OCCX,R1          IS COMP-2 USAGE SET IN OCCPDL
         CI,R3    2
         BE       PR285               YES - LEAVE AS IS
         LI,R3    1                 SET WORD ALIGN USAGE
         B        %+2
PR283    LI,R3    2                 SET DOUBLE WORD ALIGN USAGE
         STB,R3   *OCCX,R1          STORE USAGE IN OCCPDL
PR285    LI,R7    11                PICTURE CLAUSE
         LH,R3    *DLPNTR,R7
         BEZ      PR29              NO - SIZE IN DICT. IS ZERO
         LW,R3    GIFLG             YES - IS ITEM ELEMENTARY?
         BEZ      PR29              YES
         LI,R1    -87                NO - ERROR
         BAL,R11  DIAG               PICTURE ILLEGAL ON GROUP
PR29     LI,R3    0
PR30     LW,R4    L88PNTR           IS MOST RECENT DICT. ENTRY AN 88?
         BEZ      %+4                NO
         STW,R4   DLPNTR             YES - RESTORE DICT. PNTR. TO 88 ENT
         LI,R4    0                 RESET COND VAR POINTER
         STW,R4   L88PNTR
         LW,R4    LEVNUM            COMPARE LEVEL OF CURRENT DATA ENTRY
         BEZ      PR33
         CB,R4    *PDLX              TO LEVEL OF MOST RECENT PDL ENTRY
         BE       PR35              EQUAL
         BG       PR34              GREATER
         LW,R7    PDLX              LESS
PR31     CI,R7    PDL
         BE       PR32              NO LEVEL MATCH WITH ANY PDL ENTRY
         AI,R7    -2                DOES CURRENT DATA ENTRY LEVEL MATCH
         CB,R4    *R7                ANY LEVEL ALREADY IN PDL?
         BE       PR33              YES
         B        PR31
PR32     AI,R7    2                 IF LEVEL 77 OR 66 ENTRY,
         LB,R1    *R7                LEVEL SEQUENCE ERROR ALLOWABLE
         CI,R1    77
         BE       PR33
         CI,R1    66
         BE       PR33
         LI,R1    -100
         BAL,R11  DIAG              INCORRECT LEVEL SEQUENCE
PR33     BAL,R11  REMOVE
         STD,R2   *PDLX             CLEAR PDL ENTRY
         MTW,-2   PDLX              DECREMENT PDL INDEX
         LW,R4    PDLX
         CI,R4    PDL
         BE       PR36
         STW,R4   GIFLG
         B        PR30
PR34     MTW,2    PDLX              INCREMENT PDL INDEX
         B        PR36
PR35     BAL,R11  REMOVE
         STD,R2   *PDLX
PR36     LCI      7                 ROUTINE EXIT
         LM,R1    PRTEMP
         B        *PREXIT
PR40     LW,R3    1,R4              SECOND WORD OF ENTRY
         SLS,R3   -13               OBTAIN 19-BIT ADDRESS
         CI,R3    0                 SET CONDITION CODE
         B        *R11              EXIT
PRTEMP   RES      7
PREXIT   RES      1
PLEVL    DATA     0
PNVLVL   DATA     0
VARFL    DATA     0
ADDDL    DATA     3
DDREG    RES      7
         TITLE    'REMOVE'
         PAGE
REMOVE   STW,R11  RMEXIT
         LI,R2    0
         LI,R3    0
         LCI      11
         STM,R1   RMTEMP
         LI,R7    1                 GET DICT. ADDRESS OF ENTRY
         LH,R3    *PDLX,R7           BEING REMOVED
         AW,R3    DLORG
         LI,R7    5
         LB,R4    *DLPNTR
         AW,R4    DLPNTR
         SW,R4    DLORG             MAKE END OF RANGE ENTRY IN DICT.
         STH,R4   *R3,R7
         LI,R5    11
         LI,R6    14
         CH,R2    *R3,R5            IS DICT. SIZE FIELD ZERO?
         BNE      RM0               NO
         LB,R4    *R3,R6            IS CLASS COMP,COMP-1, OR COMP-2?
         AND,R4   L(X'F')
         CI,R4    X'C'               OR INDEX
         BL       RM0               NO
         LW,R4    COMPSIZ-12,R4     SET APPROPRIATE SIZE IN DICT.
         STH,R4   *R3,R5
RM0      LW,R4    GIFLG             IS ENTRY BEING REMOVED A GROUP?
         BEZ      RM1               NO
         LI,R7    4                 YES - COMPUTE GROUP SIZE BY SUBT.
         LW,R9    *R3,R7             DISP. IN ENTRY BEING REMOVED
         AND,R9   L(X'FFFFFF')       FROM CURRENT DISP.
         LCW,R9   R9
         LB,R4    SHFLG
         CI,R4    8
         BE       %+5
         LW,R4    LEVNUM
         BNEZ     %+3
         LB,R4    SHPREV
         B        %+2
         LB,R4    SHFLG
         EXU      STDISP3-8,R4       SAVE RESULT IN R9 FOR LATER USE
         LH,R4    *PDLX             DOES GROUP ENTRY BEING REMOVED
         AND,R4   L(X'FC')           HAVE USAGE CLAUSE
         BEZ      RM1                NO
         STW,R2   GRPUSG            RESET GROUP USAGE
RM1      LB,R4    *R3,R6            IS CLASS OF ENTRY COMPUTATIONAL-3
         AND,R4   L(X'F')
         CI,R4    8                  SIGNED OR UNSIGNED?
         BE       RM1A               YES
         CI,R4    9
         BNE      RM01              NO
RM1A     LI,R7    8                 IF LEVEL 66, DO NOT ADJUST SIZE
         LB,R4    *R3,R7              FIELD SINCE IT ALREADY CONTAINS
         CI,R4    66                  THE CORRECT SIZE
         BE       RM01
         LH,R4    *R3,R5            IF NO. OF DIGITS IN SIZE FIELD EVEN,
         AND,R4   L(X'1')            SET ZERO FILL (J FIELD) IN DICT.
         BNEZ     RM00
*
         LI,R7    8                 DO NOT SET J FIELD IF LEVEL 66
         LB,R4    *R3,R7              BECAUSE THIS FIELD IS NOT SET
         CI,R4    66                  IN THE ORIGINAL (RENAMED) ENTRY
         BE       RM00
*
         LI,R4    X'10'
         LI,R7    3
         AWM,R4   *R3,R7
RM00     LH,R4    *R3,R5            IS SIZE ZERO?
* THESE FIXES ARE TO CORRECT THE LINE THE DIAGNOSTICS ARE ON            COBOL21
         BNEZ     RM01A                                                 COBOL21
         LI,R7    1                                                     COBOL21
         LW,R7    *R3,R7            GET CARDNO FOR DIAG                 COBOL21
         XW,R7    CARDNO            STORE CARDNO AND SAVE OLD CARDNO    COBOL21
         LI,R1    102                                                   COBOL21
         BAL,R11  DIAG                                                  COBOL21
         STW,R7   CARDNO            RESTORE ORIGINAL CARDNO             COBOL21
RM01A    RES      0                                                     COBOL21
         SLS,R4   -1                 AS FOLLOWS---
         AI,R4    1                  INTEGRAL PART (NO. DIGITS/2) + 1
         STH,R4   *R3,R5            STORE RESULT IN SIZE FIELD
RM01     LI,R4    X'100'
         LI,R7    1                 DOES ENTRY BEING REMOVED CONTAIN
         AND,R4   *PDLX,R7           AN OCCURS CLAUSE?
         BNEZ     RM02               YES'
         STW,R2   OCCUT              NO - CLEAR OCCURS USAGE TYPE FLAG
         LW,R4    GIFLG             IS ENTRY A GROUP ITEM
         BEZ      RM15              NO
         STH,R9   *R3,R5            YES - STORE GROUP SIZE IN DICT.
         CI,R9    X'FFFF'           SEE IF SIZE <= 65,535               COBOL21
         BLE      RM16              O. K.                               COBOL21
         LI,R1    102               GREATER                             COBOL21
         BAL,R11  DIAG                                                  COBOL21
         B        RM16
RM02     LI,R6    15
         LW,R4    GIFLG             IS ENTRY BEING REMOVED A GROUP?
         BEZ      RM7               NO
         LB,R4    *OCCX,R7          YES - EXAMINE USAGE TYPE IN OCCPDL
         BEZ      RM4                FOR COMP, COMP-1, COMP-2, OR INDEX
         CI,R4    1
         BE       RM2
         LI,R4    7                 DOUBLEWORD ALIGNMENT NECESSARY
         LI,R5    X'FFFF8'
         B        RM3
RM2      LI,R4    3                 WORD ALIGNMENT NECESSARY
         LI,R5    X'FFFFC'
RM3      AW,R9    R4                GROUP SIZE NOW ADJUSTED
         AND,R9   R5                 TO REQUIRED BOUNDARY
RM4      LW,R10   R3                SET BEGINNING DICT. ADDR IN OCC RNGE
         LB,R1    *R3,R6            GET CURRENT LEVEL OF NESTING
         AI,R1    11                SET INDEX TO RELEVANT FACTOR FIELD
RM5      STH,R9   *R10,R1           STORE GROUP SIZE IN DICT. FACTOR
         CW,R10   DLPNTR            ARE ALL FACTORS IN OCCURS RANGE FULL
         BE       RM6               YES
         LB,R11   *R10              NO - ADVANCE TO NEXT DICT. ENTRY
         AW,R10   R11
         B        RM5
RM6      STW,R9   FACTOR
         LH,R8    *OCCX,R7
         LW,R11   R9
         AI,R8    -1                MULTIPLY (NO. OF OCCURS - 1) TIMES
         MW,R11   R8                 GROUP SIZE FOR LATER
         B        RM10
RM7      LI,R5    11
         LH,R9    *R3,R5            ENTRY IS ELEMENTARY
RM9      LB,R1    *R3,R6            STORE SIZE IN RELEVANT FACTOR FIELD
         AND,R1   L(X'F')
         AI,R1    11
*      SIDR  SIG7-3345                                                  COBOL21
         LW,R10   R3                                                    COBOL21
RM9GZ    STH,R9   *R10,R1           STORE DEMINSION FACTOR              COBOL21
         CW,R10   DLPNTR            IS THERE ANY MORE ENTRIES           COBOL21
         BE       RM9GY             NO                                  COBOL21
         LB,R11   *R10              BUILD ADDRESS                       COBOL21
         AW,R10   R11               OF NEXT ENTRY                       COBOL21
         B        RM9GZ                                                 COBOL21
RM9GY    STW,R9   FACTOR                                                COBOL21
*      SIDR  SIG7-3345                                                  COBOL21
RM10     LI,R4    X'800'            DOES DATA ENTRY BEING REMOVED
         AND,R4   *PDLX,R7           CONTAIN A KEY CLAUSE?
         BEZ      RM14              NO
         LI,R4    20                YES - ARE ANY ENTRIES REMAINING
RM11     CW,R2    KEYTAB-1,R4        IN KEYTAB
         BNE      RM12              YES - ERROR
         BDR,R4   RM11
         B        RM14              NO
* THESE FIXES ARE TO CORRECT THE LINE THE DIAGNOSTICS ARE ON            COBOL21
RM12     LW,R4    *R3,R7            GET LINE NO FOR DIAG                COBOL21
         XW,R4    CARDNO            STORE CARDNO AND SAVE OLD CARDNO    COBOL21
         LI,R1    101               UNDEFINED TABLE KEY                 COBOL21
         BAL,R11  DIAG                                                  COBOL21
         STW,R4   CARDNO            RESTORE ORIGINAL CARDNO             COBOL21
         LI,R4    20
RM13     STW,R2   KEYTAB-1,R4       CLEAR KEYTAB
         BDR,R4   RM13
RM14     LI,R5    11                STORE COMPUTED GROUP OR ELEM. ITEM
         STH,R9   *R3,R5             SIZE IN DICT.
         MH,R9    *OCCX,R7          MULTIPLY SIZE BY NO. OF OCCURS
         STW,R9   OCCDISP           SAVE FOR BUMP OF ELEM. OCCURS DISP.
         CI,R9    X'FFFF'           SEE IF GREATER 65K                  COBOL21
         BLE      RM141             SIZE O.K.                           COBOL21
         LI,R1    288               ISSUE DIAG                          COBOL21
         BAL,R11  DIAG                                                  COBOL21
RM141    RES      0                                                     COBOL21
         LB,R4    *OCCX             DOES ENTRY HAVE A TDB ASSOC. WITH IT
         BEZ      RM144+1            NO
         LH,R1    *OCCX,R7          YES
         LH,R6    *DBXORG,R4        STORE NO. OF OCCURS IN C FIELD
         AW,R6    DBORG                OF TDB
         SLS,R6   -1
         AI,R6    3
         STH,R1   0,R6
         AI,R6    1                 STORE CURRENT OCCURS FACTOR
         LW,R1    FACTOR            TEMPORARILY IN 3RD WD. OF TDB FOR
         STH,R1   0,R6              LATER USE IN GENERATION OF INDICES
         LB,R4    *OCCX
         LI,R7    4
         LW,R1    OCCX               YES - IS CURRENT LEVEL OF OCCURS
RM142    AI,R1    -1                 GREATER THAN 1
         CI,R1    OCCPDL-1
         BE       RM144              NO
         LB,R8    *R1                YES - GET TDB# AT NEXT OUTER LEVEL
         LH,R6    *DBXORG,R4         AND STORE IN RELEVANT T FIELD OF
         AW,R6    DBORG              TDB ASSOC. WITH ENTRY BEING REMOVED
         AW,R6    R7
         STB,R8   0,R6
         AI,R7    1
         B        RM142
RM144    LI,R7    1
         LB,R1    *OCCX,R7          SAVE USAGE TYPE
         STB,R1   OCCUT
         STW,R2   *OCCX             REMOVE MOST RECENT ENTRY FROM OCCPDL
         MTW,-1   OCCX              DECREMENT OCCPDL POINTER
         LW,R4    OCCX
         CI,R4    OCCPDL-1
         BE       %+2
         STB,R1   *OCCX,R7          PROPAGATE USAGE TO PREV. OCCURS LEVEL
RM15     CH,R2    *R3,R5            IS SIZE FIELD ZERO
         BNE      RM16              NO
* THESE FIXES ARE TO CORRECT THE LINE THE DIAGNOSTICS ARE ON            COBOL21
         LW,R4    *R3,R7            GET LINE NO FOR DIAG                COBOL21
         XW,R4    CARDNO            STORE CARDNO AND SAVE OLD CARDNO    COBOL21
         LI,R1    102               SIZE NOT DETERMINABLE               COBOL21
         BAL,R11  DIAG                                                  COBOL21
         STW,R4   CARDNO            RESTORE ORIGINAL CARDNO             COBOL21
RM16     LH,R4    *R3,R5            SAVE SIZE FOR USE AS LABEL RECORD
         AND,R4   =X'FFFF'          ALLOW FOR SIZE = 65535              COBOL21
         STW,R4   BASE10DP           LENGTH IF NEEDED
         LI,R4    X'400'            IS ENTRY BEING REMOVED A
         AND,R4   *PDLX,R7           CONDITIONAL VARIABLE?
         BEZ      RM17              NO
         LI,R1    8
         LW,R4    R3                YES - STORE CLASS AND SIZE FROM
         LI,R6    14                 C.V. DICT. ENTRY INTO ALL
         LB,R8    *R4,R6             CONDITION NAME DICT. ENTRIES
         LH,R9    *R4,R5             WHICH FOLLOW
         LB,R10   *R4
         AW,R4    R10
         LI,R10   88
         CB,R10   *R4,R1
         BNE      RM17
         STB,R8   *R4,R6
         STH,R9   *R4,R5            ITERATE UNTIL FIRST NON-88
         B        %-9                DICT. ENTRY ENCOUNTERED
RM17     LW,R4    GIFLG             IS ENTRY A GROUP ITEM?
         BEZ      RM18              NO
         LW,R6    LEVNUM            YES
         BNEZ     %+3
         LB,R6    SHPREV            IF OCCURS PRESENT, ADD PREVIOUSLY
         B        %+2                COMPUTED FACTOR TO APPROPRIATE
         LB,R6    SHFLG              DISPLACEMENT COUNTER
         LI,R4    X'100'            ELSE TRANSFER TO RM19
         AND,R4   *PDLX,R7
         BEZ      RM19
         EXU      STDISP1-8,R6
         LB,R4    OCCUT             IS PADDING TEST REQUIRED
         BEZ      RM19               NO
         CI,R4    1
         BE       RM173
         LI,R1    7                 SET DISP. TO NEXT SINGLE OR
         LI,R5    X'FFFF8'           DOUBLE WORD BOUNDARY, IF REQUIRED
         B        RM176
RM173    LI,R1    3
         LI,R5    X'FFFFC'
RM176    EXU      INDXDSP-8,R6      LOAD R4 WITH APPROPRIATE DISP.
         AW,R4    R1
         AND,R4   R5
         EXU      STDISP4-8,R6
         B        RM19
RM18     LI,R4    X'100'            ITEM BEING REMOVED IS ELEMENTARY
         LI,R6    1                 IF OCCURS PRESENT, BUMP DISPLACEMENT
         AND,R4   *PDLX,R6           BY PREVIOUSLY COMPUTED PRODUCT OF
         BEZ      %+3                SIZE * NO. OF OCCURS
         LW,R4    OCCDISP            ELSE BUMP DISPLACEMENT BY SIZE
         B        %+2
         LH,R4    *R3,R5
         AND,R4   =X'FFFF'          ALLOW FOR SIZE = 65535              COBOL21
         LB,R6    SHFLG
         CI,R6    X'C'              IS IN REPORT SECTION
         BNE      RM186             NO
         LW,R1    FTRR              IS THIS 1ST TIME HERE
         BEZ      RM183             NO
         STW,R2   FTRR              YES - RESET 1ST TIME FLAG
         B        RM186
RM183    LW,R1    GISUMFLG          IF GROUP INDICATE/SUM
         BEZ      RM24               FLAG SET, BUMP DISP. AND RESET FLAG
         STW,R2   GISUMFLG           ELSE BYPASS
         B        RM19-1
RM186    CI,R6    8
         BE        RM187                                                COBOL21
         LW,R6    LEVNUM
         BNEZ     %+3
         LB,R6    SHPREV
         B        %+2
         LB,R6    SHFLG
         CI,R6     8               CHECK IF IN FILE-SECTION             COBOL21
         BNE       RM19-1          NO                                   COBOL21
RM187    LB,R1     *R3,R6          LOAD LEVEL NUMBER                    COBOL21
         CI,R1     66              IF 66 ITEM DO                        COBOL21
         BE        RM19                NOT INCREASE SIZE OF DISPLACEMENTCOBOL21
         EXU      STDISP2-8,R6
RM19     LI,R1    1                 IS THIS END OF REDEFINES RANGE
         LW,R4    *PDLX,R1
         SLS,R4   -13               OBTAIN 19-BIT DISPLACEMENT
         CW,R4    R2
         BE       RM21              NOT END OF RANGE
         LI,R5    X'7FFFF'          ARE REDEFINING/REDEFINES AREAS EQUAL
         EXU      CMPDISPS-8,R6
         BE       RM21              YES
         BL       RM20              NO - SET DISPLACEMENT TO THE
         EXU      STDISP4-8,R6       LARGEST OF THE TWO VALUES
RM20     LB,R4    *PDLX             IS ENTRY LEVEL 1 OR 77?
         CI,R4    1
         BE       RM21              YES
         CI,R4    77
         BE       RM21
* THESE FIXES ARE TO CORRECT THE LINE THE DIAGNOSTICS ARE ON            COBOL21
         LI,R6    1                                                     COBOL21
         LW,R6    *R3,R6            GET CARDNO                          COBOL21
         XW,R6    CARDNO            STORE CARDNO AND SAVE OLD CARDNO    COBOL21
         LI,R1    103        REDEFINING AND REDEFINES AREAS NOT EQUAL   COBOL21
         BAL,R11  DIAG                                                  COBOL21
         STW,R6   CARDNO            RESTORE ORIGINAL CARDNO             COBOL21
RM21     LI,R6    6                 SEARCH KEYTAB TO DETERMINE IF ENTRY
         LH,R10   *R3,R6             BEING REMOVED IS A KEY DATA NAME
         LI,R4    2
RM22     CH,R10   KEYTAB-1,R4
         BE       RM23              IT IS
         CI,R4    40                HAS ALL OF KEY TABLE BEEN SEARCHED?
         BE       RM24               YES
         AI,R4    2                  NO
         B        RM22
RM23     SLS,R4   -1
         LW,R10   KEYTAB-1,R4       STORE KEY NUMBER AND ASCENDING -
         AND,R10  L(X'FF')           DESCENDING INDICATOR IN O FIELD
         LI,R6    21                 OF CURRENT DICT. ENTRY
         STB,R10  *R3,R6
         STW,R2   KEYTAB-1,R4       DELETE KEYTAB ENTRY
ADDR6    AI,6     15                GET LEVEL ADDR
         STB,R10  TEMPKEY           SAVE KEY INDICATER
         LB,R10   *R3,6
         CI,R10   X'58'             CHECK LEVEL NO 88
         BNE      RELOAD
         LB,R10   TEMPKEY
         AI,6     13
         STB,R10  *R3,6             STORE KEY IN COND-NAME
         AI,6     4                 INCREASE 1 WORD
         B        ADDR6
TEMPKEY  DATA     0
RELOAD   LI,6     21
         LB,R10   TEMPKEY
RM24     LCI      11                EXIT
         LM,R1    RMTEMP
         B        *RMEXIT
STDISP1  AWM,R11  DISP
         AWM,R11  BASE1DSP
         AWM,R11  BASEFDSP         LINKAGE
         AWM,R11  BASE9DSP
         AWM,R11  DISP
STDISP2  AWM,R4   DISP
         AWM,R4   BASE1DSP
         AWM,R4   BASEFDSP         LINKAGE
         AWM,R4   BASE9DSP
         AWM,R4   DISP
STDISP3  AW,R9    DISP
         AW,R9    BASE1DSP
         AW,R9    BASEFDSP         LINKAGE
         AW,R9    BASE9DSP
         AW,R9    DISP
STDISP4  STW,R4   DISP
         STW,R4   BASE1DSP
         STW,R4   BASEFDSP         LINKAGE
         STW,R4   BASE9DSP
         STW,R4   DISP
CMPDISP  CW,R4    DISP
         CW,R4    BASE1DSP
         CW,R4    BASEFDSP         LINKAGE
         CW,R4    BASE9DSP
         CW,R4    DISP
CMPDISPS CS,R4    DISP
         CS,R4    BASE1DSP
         CS,R4    BASEFDSP         LINKAGE
         CS,R4    BASE9DSP
         CS,R4    DISP
OCCDISP  DATA     0                 DISP. BUMP FACTOR WITH ELEM. OCCURS
RMTEMP   RES      11
RMEXIT   RES      1
COMPSIZ  DATA     4                 INDEX
         DATA     4                 COMP   BINARY
         DATA     4                 COMP-1 SINGLE PREC. FLT. PNT.
         DATA     8                 COMP-2 DOUBLE PREC. FLT. PNT.
         TITLE    'TERMINATE FILE'
         PAGE
TERFIL   LCI      7
         STM,R1   TETEMP
         STW,R11  TEREXIT
         LW,R2    MRL               IS MRL = 0?
         BEZ      TE1               YES
         LW,R3    LRFLAG            NO - IS LABEL RECORD FLAG SET
*        IF IT BECOMES DESIREABLE TO IMPLEMENT A FIX FOR S27526         COBOL21
*        WHICH WAS A PROBLEM WITH LABEL RECORDS AND ALSO BLOCKING       COBOL21
*        THE FOLLOWING CODE COULD BE USED.
*        NOTE THESE INST REPLACE THE BNEZ  TE2  WHICH FOLLOWS           COBOL21
*                                                                       COBOL21
*        +3411,3411                                                     COBOL21
*           BEZ   %+2    NOT LABEL RECORD
*           LI,R2 0      LABEL REC--USE 0 DISP
*                                                                       COBOL21
*
*        ALSO IF IT IS DESIREABLE TO MAKE ALL LABEL RECORDS EQUAL       COBOL21
*        TO 255 CHARACTERS (EXCEPT ANS TAPE), THE FOLLOWING PLUS        COBOL21
*        CARDS SHOULD BE ADDED TO THE RUNTIME ROUTINE DECL              COBOL21
*        +337,341                                                       COBOL21
*                                                                       COBOL21
         BNEZ     TE2               YES - LEAVE MRL AS IS
         CW,R2    DISP              NO - IS DISP LESS THAN OR = MRL?
         BG       TE2               YES
TE1      LW,R2    DISP              NO - USE CURRENT DISP
TE2      LW,R3    DBXORG            STORE MRL IN DDB (H FIELD)
         AND,R3   L(X'FFFFFF')       CORRESPONDING TO FILE BEING
         SLS,R3   1                  TERMINATED
         AW,R1    R3
         LH,R1    0,R1
         AW,R1    DBORG
         SLS,R1   -2
         LI,R3    5
         LH,R4    *R1,R3
         BEZ      TE25
         AND,R4   =X'FFFF'          STRIP EXTENDED SINE                 COBOL21
         CW,R2    R4                MRL VS RECORD CONTAINS              COBOL21
         BE       TE25              SAMEE SAMEE HOKAY                   COBOL21
         LW,R4    R1                NO - ISSUE WARNING DIAGNOSTIC
         LW,R6    DBLPREV
         XW,R6    CARDNO
         LI,R1    125
         BAL,R11  DIAG
         STW,R6   CARDNO
         LW,R1    R4
TE25     STH,R2   *R1,R3            R1 CONTAINS THE DB# OF TERM. FILE
         LI,R4    0
         STW,R4   MRL               RESET MRL FOR NEXT FILE
         LI,R3    3
         LW,R2    SEGNUM            STORE CURRENT SEGMENT NO. IN
         STH,R2   *R1,R3             F FIELD OF DDB
         LW,R2    IDXX
         CI,R2    IDXTAB            ANY ENTRIES IN INDEX TABLE?
         BE       TE5               NO
         BAL,R11  CKDDDOUT          CHECK IF  DDD SHOULD BE OUTPUT      COBOL21
GENINDX  LI,R5    0
         LB,R6    SHPREV
         CI,R6    8                 PROCESSING FILE INDEX
         BNE      TE27               NO
*        THE FOLLOWING FIXES CHANGE THE INDEX AREA SIZE TO CONFORM      COBOL21
*        TO THE SIZE INDICATED BY THE PROGRAM BEING COMPILED.           COBOL21
*                                                                       COBOL21
         LI,R3    37                PICK UP SIZE OF                     COBOL21
         LB,R3    *R1,R3            INDEX AREA                          COBOL21
         SLS,R3   2                 CHG WORDS TO BYTES                  COBOL21
         STW,R3   DISP              SET STARTING INDEX DISP. FOR FILE
TE27     AI,R2    -2
         MTW,-2   IDXX
         LB,R3    *DLPNTR           GENERATE AN INDEX DICT. ENTRY
         AWM,R3   DLPNTR            BUMP DICT. POINTER
TE3      LW,R4    L(X'7000000')     A=7    B=0
         STW,R4   *DLPNTR
         LI,R3    1
         LW,R4    *R2,R3            MOVE SOURCE LINE NO. AND SUB FROM
         STW,R4   *DLPNTR,R3         CURRENT IDXTAB ENTRY TO DICT.
         LH,R4    *R2,R3
         LI,R3    6
         STH,R4   *DLPNTR,R3        R# FROM IDXTAB TO DICT.
         LI,R4    X'CC'             SET TYPE IN DICT. TO
         LI,R3    14                 COMPILER GENERATED ITEM
         STB,R4   *DLPNTR,R3         AND CLASS TO INDEX
         LB,R6    SHPREV
         CI,R6    X'A'              SEE IF IN LINKAGE                   COBOL21
         BNE      %+2               NO                                  COBOL21
         AI,R6    -1                YES-FORCE INDX TO WK-STO            COBOL21
         EXU      INDXDSP-8,R6
         AI,R4    3                 WORD ALIGN CURRENT DISPLACEMENT
         AND,R4   L(X'FFFFFFFC')
         LI,R3    4
         STW,R4   *DLPNTR,R3        CURRENT DISPLACEMENT TO DICT.
         LB,R3    *R2                AND TO B FIELD OF CURRENT TDB
         LH,R3    *DBXORG,R3
         AW,R3    DBORG
         SLS,R3   -1
         AI,R3    4
         LH,R7    0,R3               GET OCCURS FACTOR
         AI,R3    -3
         SLS,R3   -1                WA(TDB)                             COBOL21
         LB,R15   *R3               FIELD A OF TDB                      COBOL21
         STB,R15  R4                STORE IN DISPLACEMENT               COBOL21
         STW,R4   *R3               STORE FIELD A,B IN TDB (ID,DISP)    COBOL21
         EXU      GETBASE-8,R6
         CI,R6    8
         BG       %+2
         AI,R3    50
         LI,R4    16                BASE NUMBER + 50 TO DICT.
         STB,R3   *DLPNTR,R4         INDICATING INDEXED FILE
         LB,R4    *R2
         LI,R3    20                CURRENT TDB# FROM IDXTAB TO DICT.
         STB,R4   *DLPNTR,R3
         LI,R4    4
         LI,R3    11                INDEX WORD SIZE (ALWAYS 4 BYTES)
         STH,R4   *DLPNTR,R3         TO DICT.
         LI,R3    12                STORE CURRENT OCCURS FACTOR
         STH,R7   *DLPNTR,R3         IN Q OF DICT.
         AI,R5    4                 UPDATE TTL. INDEX WORD LENGTH
         LW,R4    DLPNTR
         LB,R3    *DLPNTR
         AW,R3    DLPNTR
         STW,R3   DLPNTR
         SW,R3    DLORG             BUMP DICT. POINTER AND STORE NEW
         LI,R7    5                  REL. ADDR. IN END OF RANGE FIELD
         STH,R3   *R4,R7             OF DICT. ENTRY JUST GENERATED
         CI,R2    IDXTAB            ANY MORE INDEX TABLE ENTRIES?
         BE       TE4               NO
         EXU      INDXDB-8,R6       BUMP DISPLACEMENT
         AI,R2    -2
         MTW,-2   IDXX
         B        TE3               PROCESS NEXT INDEX NAME
TE4      LI,R3    -7
         AWM,R3   DLPNTR
         LB,R3    SHPREV
         CI,R3    8
         BE       TE41              JUMP IF IN FILE SECTION             COBOL21
         CI,R3    12                                                    COBOL21
         BE       *TEREXIT          RETURN IF IN REPORT SECTION         COBOL21
         CI,R3    X'A'              SEE IF IN LINKAGE                   COBOL21
         BNE      %+2               NO                                  COBOL21
         AI,R3    -1                YES-USE WK-STO                      COBOL21
         EXU      WSCSINDX-9,R3
         B        *R11
TE41     LI,R3    37                STORE NO. OF BYTES IN FILE USED FORCOBOL21
         LB,R4    *R1,R3            INDEXING IN Q FIELD OF DDB
         SLS,R5   -2                CONVERT TO WORD COUNT               COBOL21
         AW,R4    R5
         STB,R4   *R1,R3
TE5      LI,R3    0                 RESET DISPLACEMENT COUNTER
         STW,R3   DISP
         LCI      7
         LM,R1    TETEMP
         B        *TEREXIT
*  IF THE IS A RENAMES OUTPUT  INDEXES IN ANOTHER DDD                   COBOL21
CKDDDOUT LW,R5    L66FLG            ARE THERE RENAMES                   COBOL21
         BEZ      *R11              NO  RETURN                          COBOL21
         LI,R5    0                 RESET  RENAMES  FLAG                COBOL21
         STW,R5   L66FLG                                                COBOL21
         B        OUTSEG            OUTPUT  DDD  + RETURN               COBOL21
TEREXIT  RES      1
TETEMP   RES      7
INDXDSP  LW,R4    DISP
         LW,R4    BASE1DSP
         LW,R4    BASEFDSP         LINKAGE
         LW,R4    BASE9DSP
INDXDB   MTW,4    DISP
         MTW,4    BASE1DSP
         MTW,4    BASEFDSP         LINKAGE
         MTW,4    BASE9DSP
WSCSINDX AWM,R5   BASE1DSP
         AWM,R5   BASEFDSP         LINKAGE
         AWM,R5   BASE9DSP
         TITLE    'SQUEEZ - DICTIONARY COMPRESSION ROUTINE'
         PAGE
*        THE SQUEEZ ROUTINE WAS FORMENLY INOPERABLE--THAT IS IT HAD     COBOL21
*        A  B  *R11 AS THE FIRST INSTRUCTION BEFORE THE CODE WAS        COBOL21
*        CHANGED  ON 5/02/72                                            COBOL21
SQUEEZ   LCI      15                                                    COBOL21
         STM,R1   SQUTEMP                                               COBOL21
         LW,R9    L(X'FFFFFF')      SET EOR MASK                        COBOL21
         LI,R2    6                 R NUMBER INDEX                      COBOL21
         LI,R3    2                 EOR INDEX                           COBOL21
         LI,R1    8                 LEVEL INDEX                         COBOL21
         LI,R6    0                                                     COBOL21
         STW,R6   AFL               CLEAR ACCUN FILLER LENGTH           COBOL21
         STW,R6   FILFLG            TORN OFF FILLER FLAG                COBOL21
*        CALCULATE ORIGINAL DDD SIZE FOR OUTSEG                         COBOL21
         LB,R6    *DLPNTR                                               COBOL21
         AW,R6    DLPNTR            NEXT LOCATION                       COBOL21
         SW,R6    DLORG             NEXT LOC - FIRST LOC                COBOL21
         STW,R6   SQSIZ             SIZE                                COBOL21
         LW,R10   DLORG             SET POINTER TO FIRST DICTIONARY     COBOL21
         STW,R10  SECPNTR                                               COBOL21
         STW,R10  R13               SAVE FOR END OF SQUEEZ PROCESSING   COBOL21
*        SET LEVEL NUMBER FOR GROUPS                                    COBOL21
         LB,R7    *DLORG            SIZE OF 1ST ENTRY                   COBOL21
         AW,R7    DLORG             2ND ENTRY                           COBOL21
         LB,R10   *R7,R1            LEVEL NUMBER OF 1ST GROUP           COBOL21
         STW,R10  SQLEV             SAVE LEVEL NUMBER                   COBOL21
         STW,R7   DICPNTR           INITIALIZE DDD POINTER              COBOL21
         CW,R7    DLPNTR            WAS THERE ONLY ONE ENTRY            COBOL21
         BG       SQU8              YES                                 COBOL21
         LS,R8    *DICPNTR,R3                                           COBOL21
         STW,R8   SQEOR             INITIALIZE EOR                      COBOL21
SQU10    RES      0                                                     COBOL21
         LW,R6    DICPNTR                                               COBOL21
         LW,R7    3,R6                                                  COBOL21
         CI,R7    3                 IS THIS ODO                         COBOL21
         BANZ     SQU11             YES--NEVER SQUEEZ                   COBOL21
         LH,R7    *DICPNTR,R2       GET R# FROM CURRENT DICT ENTRY      COBOL21
         CI,R7    -1                IS IT A FILLER                      COBOL21
         BE       SQU4              YES                                 COBOL21
SQU11    RES      0                                                     COBOL21
         LCW,R6   AFL               SUBTRACT AFL FROM ALL DDD ENTRIES   COBOL21
         BEZ      SQU2              NO FILLER                           COBOL21
SQU12    RES      0                                                     COBOL21
         LW,R10   DICPNTR           CURRENT DDD ITEM                    COBOL21
         STW,R10  THRPNTR           SAVE FOR LATER                      COBOL21
SQU13    RES      0                                                     COBOL21
         LCW,R6   AFL               SUBTRACT AFL FROM ALL DDD ENTRIES   COBOL21
         BAL,R11  SQU6              PROCESS CURRENT GROUP               COBOL21
*        SUBTRACT FROM ALL OTHER ENTRIES                                COBOL21
         LW,R5    DLPNTR                                                COBOL21
SQU3     RES      0                                                     COBOL21
         AWM,R6   *THRPNTR,R3       SUBTRACT AFL FROM DDD ENTRIES       COBOL21
         LB,R4    *THRPNTR          POINT TO NEXT ENTRY                 COBOL21
         AWM,R4   THRPNTR                                               COBOL21
         CW,R5    THRPNTR           HAVE ALL ENTRIES BEEN PROCESSED     COBOL21
         BGE      SQU3              NO                                  COBOL21
*        MOVE ENTRIES UP IN DDD                                         COBOL21
         LW,R10   DLPNTR                                                COBOL21
         SLS,R10  2                CHANGE ADDRESS TO BYTES              COBOL21
         LW,R5    FORPNTR           ADDRESS OF RECEIVING FIELD FOR MBS  COBOL21
         LB,R4    *DICPNTR          LENGTH IN WORDS                     COBOL21
         STB,R4   R5                                                    COBOL21
         LW,R4    DICPNTR           SENDING FIELD                       COBOL21
         SLS,R4   2                 CHANGE TO BYTES                     COBOL21
         SLS,R5   2                                                     COBOL21
SQU31    RES      0                                                     COBOL21
         MBS,R4   0                 MOVE                                COBOL21
         CW,R4    R10               ARE WE FINISHED                     COBOL21
         BG       SQU32             YES                                 COBOL21
         LB,R7    0,R4              SIZE OF NEXT ITEM--R4 POINTS TO NEXTCOBOL21
         SLS,R7   2                 CHANGE TO BYTE                      COBOL21
         STB,R7   R5                STORE IN RECEIVING FLD              COBOL21
         B        SQU31                                                 COBOL21
SQU32    RES      0                                                     COBOL21
         AWM,R6   DLPNTR            ACCUM FILLER LENGTH                 COBOL21
         LI,R6    0                                                     COBOL21
         STW,R6   AFL                                                   COBOL21
         LW,R6    FORPNTR                                               COBOL21
         STW,R6   DICPNTR                                               COBOL21
         LW,R6    DLORG                                                 COBOL21
         STW,R6   SECPNTR           RESET SECPNTR                       COBOL21
         MTW,-1   SQFIL             RESET FILLER FLAG                   COBOL21
         B        SQU10                                                 COBOL21
SQU2     RES      0                                                     COBOL21
         LS,R8    *DICPNTR,R3                                           COBOL21
         STW,R8   SQEOR                                                 COBOL21
         LW,R7    DICPNTR                                               COBOL21
         LW,R10   3,R7                                                  COBOL21
         CI,R10   3                 IS ARRAY ITEM ?  9/25/74            COBOL21
         BANZ     SQU21             YES--NEVER SQUEEZ                   COBOL21
         LH,R10   *DICPNTR,R2       IS THIS ENTRY A FILLER              COBOL21
         CI,R10   -1                                                    COBOL21
         BLE      %+2               YES                                 COBOL21
SQU21    RES      0                                                     COBOL21
         LW,R13   DICPNTR           NO--SAVE ADDRESS FOR SQU8           COBOL21
         LI,R7    7                 GROUP INDEX                         COBOL21
         LH,R10   *DICPNTR,R7       FIELDS H--K                         COBOL21
         CI,R10   X'F00'            IS THIS A GROUP                     COBOL21
         BANZ     SQU22             NO                                  COBOL21
         LB,R12   *DICPNTR,R1       SAVE LEVEL NUMBER                   COBOL21
SQU22    RES      0                                                     COBOL21
         LB,R7    *DICPNTR                                              COBOL21
         AWM,R7   DICPNTR           NEXT ITEM                           COBOL21
         LW,R10   DICPNTR                                               COBOL21
         CW,R10   DLPNTR                                                COBOL21
         BG       SQU8              FINISHED                            COBOL21
         LW,R7    DICPNTR                                               COBOL21
         LW,R10   3,R7                                                  COBOL21
         CI,R10   3                 IS THIS ODO                         COBOL21
         BANZ     SQU10             YES--NEVER SQUEEZ                   COBOL21
         LH,R10   *DICPNTR,R2                                           COBOL21
         CI,R10   -1                IS NEW GROUP A FILLER               COBOL21
         BG       SQU10             NO                                  COBOL21
         LB,R10   *DICPNTR,R1       CURRENT LEVEL NUMBER                COBOL21
         CW,R10   SQLEV             COMPARE WITH OLD LEVEL NUMBER       COBOL21
         BE       SQU23                                                 COBOL21
         CW,R10   R12               COMPARE WITH LAST SUB GROUP         COBOL21
         BG       SQU10                                                 COBOL21
SQU23    RES      0                                                     COBOL21
         LW,R10   AFL               FILLERS IN LAST GROUP ?             COBOL21
         BGZ      SQU12             YES                                 COBOL21
         B        SQU10             NORMAL PROCESSING                   COBOL21
SQU4     RES      0                                                     COBOL21
         MTW,0    SQFIL             IS THIS 1ST TIME THRU               COBOL21
         BNEZ     SQU5              NO                                  COBOL21
         MTW,1    SQFIL             TURN ON FLAG                        COBOL21
         LW,R10   DICPNTR           SAVE FILLER LOCATION                COBOL21
         STW,R10  FORPNTR                                               COBOL21
SQU5     RES      0                                                     COBOL21
         LB,R7    *DICPNTR                                              COBOL21
         AWM,R7   AFL                                                   COBOL21
         B        SQU2                                                  COBOL21
SQU6     RES      0                                                     COBOL21
*        PROCESS CURRENT GROUP SUBTRACTIONS                             COBOL21
         LW,R4    THRPNTR                                               COBOL21
         AWM,R6   *SECPNTR,R3       SUBTRACT FROM MAJOR GROUP ENTRY     COBOL21
SQU61    RES      0                                                     COBOL21
         LB,R5    *SECPNTR          SIZE                                COBOL21
         AWM,R5   SECPNTR           POINT AT NEXT ITEM                  COBOL21
         CW,R4    SECPNTR           HAVE WE REACHED CURRENT ITEM        COBOL21
         BE       *R11              RETURN IF YES                       COBOL21
         LS,R8    *SECPNTR,R3       CURRENT ITEM EOR                    COBOL21
         CW,R8    SQEOR             LAST EOR                            COBOL21
         BGE      SQU62             SUBTRACT                            COBOL21
         B        SQU61             DO NOT SUBTRACT                     COBOL21
SQU62    RES      0                                                     COBOL21
         AW,R8    R6                SUBTRACT AFL                        COBOL21
         STS,R8   *SECPNTR,R3       STORE                               COBOL21
         B        SQU61             INCREMENT POINTER                   COBOL21
SQU8     RES      0                                                     COBOL21
         LCW,R6   AFL                                                   COBOL21
         BEZ      SQU9                                                  COBOL21
         LW,R10   DLPNTR                                                COBOL21
         STW,R10  THRPNTR                                               COBOL21
         LS,R8    *DLPNTR,R3                                            COBOL21
         STW,R8   SQEOR                                                 COBOL21
         BAL,R11  SQU6                                                  COBOL21
         STW,R13  DLPNTR            CHANGE DLPNTR TO LAST NON-FILLER    COBOL21
SQU9     RES      0                                                     COBOL21
         LI,R6    0                                                     COBOL21
         MTW,1    SQFIL             TURN FLAG ON FOR OUTSEG             COBOL21
         STW,R6   FORPNTR           1ST FILLER LOCATION                 COBOL21
         STW,R6   THRPNTR           ADDRESS TO START SUBTRACT OF EOR    COBOL21
         STW,R6   SQEOR                                                 COBOL21
         STW,R6   SECPNTR                                               COBOL21
         LCI      15                                                    COBOL21
         LM,R1    SQUTEMP                                               COBOL21
         B        *R11              RETURN                              COBOL21
AFL      DATA     0                 ACCUMULATED FILLER LENGTH           COBOL21
SQFIL    DATA     0                 1ST TIME FILLER FLAG                COBOL21
SQEOR    DATA     0                                                     COBOL21
SQSIZ    DATA     0                 SAVE ORIG SIZE FOR OUT SEG          COBOL21
SQLEV    DATA     0                 GROUP POINTER                       COBOL21
DICPNTR  DATA     0                                                     COBOL21
SECPNTR  DATA     0                                                     COBOL21
THRPNTR  DATA     0                 ADDRESS TO START SUBTRACT OF EOR    COBOL21
FORPNTR  DATA     0                 1ST FILLER LOCATION                 COBOL21
SQUTEMP  RES      15                                                    COBOL21
         TITLE    'SYNLNK - SYNONYM LINKING ROUTINE'
         PAGE
SYNLNK   LCI      9
         STM,R1   SYNTEMP
         STW,R11  SYNEXIT
         LI,R7    1                 GET LAST DICT. ENTRY ADDRESS
         LW,R1    DLORG             GET FIRST DICT. ENTRY ADDRESS
         LI,R2    SYPDL             SET SYPDL POINTER TO 1ST POSITION
SY1      LI,R4    8
         LB,R3    *R1,R4            COMPARE LEVEL OF CURRENT ENTRY TO
         AND,R3   L(X'7F')
SY2      CH,R3    *R2               LEVEL OF MOST RECENT SYPDL ENTRY    COBOL21
         BG       SY3               GREATER-STORE CURRENT LEV NEXT SYPDL
         BE       SY4               EQUAL - NO ACTION NECESSARY
         AI,R2    -2                LESS - BACK UP TO 1ST EQUAL LEVEL
         B        SY2
SY3      AI,R2    2
SY4      LI,R4    5                 STORE END OF RANGE, ADDRESS, AND
         STH,R3   *R2               LEVEL OF CURRENT DICT ENTRY         COBOL21
         LH,R3    *R1,R4             INTO CURRENT SYPDL ENTRY
         STH,R3   *R2,R7
         STW,R1   *R2,R7                                                COBOL21
         LI,R4    6                 GET R# FROM DICT. AND USE AS INDEX
         LH,R4    *R1,R4             FOR LOOK-UP IN DINDEX
         CI,R4    -2                IF NAMELESS REPORT ENTRY OR FILLER
         BE       SY5                DO NOT LINK
         CI,R4    -1
         BE       SY5
         AW,R4    DXORG
         LW,R5    R1
         SLS,R5   2
         AI,R5    1                 MOVE CONTENTS OF DINDEX ENTRY TO
         OR,R5    L(X'3000000')      SYN. LINK FIELD OF CURRENT
         MBS,R4   0                  DICT. ENTRY
         LW,R6    SEGNUM
         SLS,R6   14                MOVE SEGMENT NO. AND ADDRESS
         AW,R6    R1                 OF CURRENT DICT. ENTRY TO DINDEX
         SW,R6    DLORG
         LW,R5    R4
         AI,R5    -3
         OR,R5    L(X'3000000')
         LI,R4    25                BA(R6)+1
         MBS,R4   0
         LW,R4    *R1               IS SYN. LINK FIELD OF CURRENT
         AND,R4   L(X'FFFFFF')       DICT. ENTRY ZERO?
         BEZ      SY5                YES - PROCESS NEXT DICT. ENTRY
         LW,R3    R4                 NO - IS SYNONYM IN
         SLS,R3   -14                SAME SEGMENT
         CW,R3    SEGNUM
         BNE      SY5                 NO - FURTHER CHECKS NOT REQUIRED
         AND,R4   L(X'3FFF')
         AW,R4    DLORG
         LI,R5    5                 EXAMINE F (END OF RANGE) FIELD OF
         LH,R6    *R4,R5             DICT. ENTRY TO WHICH SYN LINK PNTS
         AW,R6    DLORG             GET ACTUAL EOR                      COBOL21
         CW,R6    *R2,R7            DOES EOR POINT BEYOND CURRENT DICT ACOBOL21
         BG       SY7                YES - ERROR
         LW,R3    R2                IS EOR WITHIN SCOPE OF ENTRY AT
         AI,R3    -2                 NEXT LOWER HIERARCHY LEVEL
         CW,R6    *R3,R7                                                COBOL21
         BG       SY7                YES - ERROR
SY5      CW,R1    DLPNTR            HAVE ALL DICT. ENTRIES BEEN EXAMINED
         BNE      SY6                NO
         LCI      9                  YES - EXIT
         LM,R1    SYNTEMP
         B        *SYNEXIT
SY6      LB,R4    *R1
         AW,R1    R4                BUMP DLIST POINTER
         B        SY1               PROCESS NEXT DICT. ENTRY
SY7      LW,R8    R1
         LW,R1    *R2,R7             EXCHANGE CARD NO FOR DIAG          COBOL21
         LW,R9    1,R1                GET CARD NO                       COBOL21
         XW,R9    CARDNO             EXCHANGE IT                        COBOL21
         LI,R1    108               SYNONYMS NOT UNIQUELY QUALIFIED
         BAL,R11  DIAG
         XW,R9    CARDNO             EXCHANGE IT                        COBOL21
         LW,R1    R8
         B        SY5
SYNTEMP  RES      9
SYNEXIT  RES      1
SYPDL    DATA     0
         DATA     0
         RES      98
SYPDLORG DATA     SYPDL
         TITLE    'PHASE 2.1 WORKING STORAGE'
         PAGE
WABEG    RES      0
BASE1DSP DATA     0                 WORKING-STORAGE DISPLACEMENT COUNTER
BASE2DSP DATA     0                 REPORT SECTION
BASE4DSP DATA     48                CONDITION NAMES, EDITING MASKS
BASEFDSP DATA     0                 LINKAGE
BASE9DSP DATA     0                 COMMON-STORAGE
BASE10DP DATA     0                 LABEL RECORDS
BASENUM  DATA     0                 CURRENT BASE NUMBER
DBNTNUM  DATA     0                 MOST RECENT NON-TDB DESC. BLK. NO.
DBORG    EQU      PDBZ+3            ORIGIN OF SEG. 0  (IN BYTES)
DBPNTR   DATA     0                 SEG. 0 POINTER  (IN BYTES)
DBXORG   EQU      PDBZ+4            DBINDX ORIGIN
DECSA    RES      3                 DATA ENTRY CLUSTER SAVE AREA
DESBNUM  DATA     0                 CURRENT DESC. BLOCK NUMBER
DISP     DATA     0                 DISPLACEMENT
DLORG    EQU      PDBZ              ORIGIN OF DICT. WORK AREA
DLPNTR   DATA     0                 DICT. POINTER
DXORG    EQU      PDBZ+2            DINDEX ORIGIN  (IN BYTES)
EOFFLAG  DATA     0                 END OF EDF FLAG
FACTOR   RES      1
FILFLG   DATA     0                 FILLER FLAG
FRSTRDB  DATA     1                 FIRST RDB FLAG
FSTWSCS  DATA     0                 1ST 01 WS/CS FLAG
FTRR     DATA     1                 1ST TIME REPORT SEC. REMOVE FLAG
GIFLG    DATA     0                 GROUP INDICATOR FLAG
GISUMFLG DATA     0                 GROUP INDICATE/SUM FLAG - RPT. SECT.
GRPUSG   DATA     0                 GROUP USAGE
IDXTAB   RES,8    100               INDEX TABLE
IDXX     DATA     IDXTAB            INDEX TABLE POINTER
KEYTAB   RES      20                KEY TABLE
L1DUP    DATA     0                1ST POTENTIAL OUT OF SEQ LEV 77 CHK
L66FLG   DATA     0                 LEVEL 66 FLAG
L77DUP   DATA     0                 LEV 77 GROUP DUP. IN SECTION FLAG
L77FLG   DATA     0                 LEVEL 77 PROCESSING FLAG
L88PNTR  DATA     0                 COND. VAR. DICT. POINTER
LEV1FILL DATA     0                 LEVEL 01 FILLER FLAG
LEVNUM   DATA     0                 CURRENT DATA ENTRY LEVEL NUMBER
LPDE     DATA     0                 LENGTH OF PREVIOUS DICTIONARY ENTRY
LRFLAG   DATA     0                 LABEL RECORD FLAG
MAXLAB   DATA     0                 MAX. LABEL RCD. LENGTH WITHIN PROG.
MRL      DATA     0                 MAX. RCD. LENGTH WITHIN FILE
OCCPDL   RES      3                 OCCURS PDL
OCCUT    DATA     0                 OCCURS USAGE TYPE FLAG
OCCX     DATA     OCCPDL-1          OCCURS PDL INDEX
PREDDD   DATA     0                 LAST DDD POINTER           EL30974  COBOL21
OVERLAP  DATA     0                 REPORT LINE IMAGE OVERLAP DETECTOR
         BOUND    8
PDL      RES      100               PUSH DOWN LIST (2 WDS/ENTRY)
PDLX     DATA     WA(PDL)           PUSH DOWN LIST INDEX
PICSAV   RES      9                 PICTURE INFO. SAVE AREA
PICSAVCT DATA     0                 NO. OF CHAR. OF INFO. IN PICSAV
RAHEAD   DATA     0                 READ AHEAD FLAG
RAHEADC  RES       75              SAVE NEXT EDF CLUSTER                COBOL21
RAP1     DATA     BA(RAHEADC)+1                                         COBOL21
SAV2     DATA     0                                                     COBOL21
SAV3     DATA     0                        SAVE R3                      COBOL21
SAV4     DATA     0                        SAVE R4                      COBOL21
RDISP    DATA     0                 REDEFINITION DISPLACEMENT
REDF     DATA     0                 REDEFINITION FLAG
RGRPRNO  DATA     0                 CURRENT RPT. GRP. REF. NO.
RLINEDSP DATA     0                 REPORT LINE DISPLACEMENT
RNTAB    RES,2    50                R NUMBER TABLE
RPTDEADR DATA     0                 REPORT DATA ENTRY ADDRESS
RVEXIT   RES      1                 RETURN VALUE
RVFLAG   DATA     0                 REPORT VALUE FLAG
RVTEMP   RES      7                 RPT VALUE REG SAVE AREA
DBTEMP   RES      8                 SAVE REG FOR RDB                    COBOL21
SEGLNGTH DATA     0                 CURRENT SEGMENT LENGTH
SEGNUM   DATA     1                 CURRENT SEGMENT NUMBER
SHFLG    DATA     0                 SECTION HDR FLGS (SAME AS H IN DICT)
SHSAVE   DATA     0                 SEC. HDR. SAVE FOR LOOK AHEAD
SUMFLG   DATA     0                 SUM FLAG
TDBFLG   DATA     0           TDB FLAG
TDBFLG2  DATA     0                 2ND TDB FLAG
ADRENAME DATA     0                 DICTIONARY ADDR OF RENAMES DATA-1
WAEND    RES      0
SHPREV   DATA     0                 PREVIOUS SECTION HEADER
BASE4LIT DATA     X'1C2D0400'
         DATA,3   X'000030'
         DATA     X'F0407D00'
         DATA     X'FF7E5CF0'
         DATA     X'F0000000'
         DATA     X'1F00000F'
         DATA     X'0F000000'
         DATA     0
         DATA     X'48000000'
         DATA     0
         DATA     X'41100000'
         DATA     0
         DATA     0
         DATA     0
         TITLE    'MISC. TEMP. ROUTINES AND STORAGE'
         PAGE
ENDPH21  LI,R1    0                 TERMINATE PHASE 2.1
         STW,R1   LEVNUM
         LB,R1    SHFLG
         STB,R1   SHPREV
         BAL,R11  PROCESS
         CI,R1    X'C'              IS IN REPORT SECTION
         BNE      EOFA               NO
         BAL,R11  PRVAL
         LW,R1    DESBNUM            YES - TERMINATE LAST REPORT FILE
         BAL,R11  TERFIL
         B        EOFB
EOFA     BAL,R11  OUTINDX                                               COBOL21
EOFB     BAL,R11  VPROC
         LW,R3    L66FLG            IF LEVEL 66 FLAG SET, COMPRESSION
         BNEZ     EOF2               AND SYNONYM LINKAGE COMPLETED
         LW,R3    FILFLG
         BEZ      EOF1
         BAL,R11  SQUEEZ
EOF1     BAL,R11  SYNLNK
EOF2     STW,R11  EOFFLAG           SET END OF EDF FLAG
         BAL,R11  OUTSEG
         LI,R4    1
         LW,R3    BASE1DSP          STORE BASE COUNTERS IN APPROPRIATE
         STH,R3   PDBQB,R4           PDB LOCATIONS FOR LATER PHASE USAGE
         LH,R3    R3                PICK UP ANY BASE 1 (WORKING-STORAGE)
         STW,R3   PDBVA                 OVERFLOW, STORE IN PDBVB2
         LW,R3    BASE4DSP
         STH,R3   PDBSA             BASE 1  = WORKING STORAGE
         LW,R3    BASE9DSP          BASE 4  = COND. NAMES, EDIT. MASKS
         STH,R3   PDBUB,R4          BASE 9  = COMMON STORAGE
         LH,R3    R3                PICK UP ANY BASE 9 (COMMON-STORAGE)
         LI,R4    2                     OVERFLOW,
         STB,R3   PDBVA,R4              STORE IN PDBVB1
         LW,R3    MAXLAB            LENGTH OF LARGEST LABEL RECORD
         STH,R3   PDBVA
         B        PH21E             EXIT
         END
