         SYSTEM   SIG7FDP
         TITLE    'PHASE 3.1'
         DEF      COB31
*        DEF      DLAREA1,DLAREA2 REMOVED SIDR 1954
         REF      LSN
         REF      HSN
         REF      PDB
         REF      PDBZ
         REF      PDBCC
         REF      CORRESP
         REF      SITAD
         REF      DIAG
         REF      RDEPF
         REF      WRCRF
         REF      WRCSF
         REF      WRXRF
         REF      PDBO
         REF      USEPOINT
         REF      PH31E
         REF      CARDNO
         REF      PDBS
         REF      CHAINLK
         REF      GETIX
         REF      DICTATE
         REF      SAVERG5
         REF      XRFBUILD
         REF      CSFLINE
         REF      LINENTRY
         REF      LINENOS
         REF      XNAME
         REF      RCORDV
         REF      PDBDBG                                                COBOL31
         REF      USEND                                                 COBOL31
         PAGE
*
*
R1       EQU      1                 VOLATILE INDEX REGISTER
R2       EQU      2                 CURRENT CLUSTER
R3       EQU      3                 REF. TYPE DURING INPUT EDIT
RTYP     EQU      3
R4       EQU      4                 OUTPUT CLUSTER
OUTR     EQU      4
R5       EQU      5                 ONE
UP3      EQU      5
R6       EQU      6                 TWO
UP2      EQU      6
R7       EQU      7                 THREE
UP1      EQU      7
R8       EQU      8                 CONTROL BYTE
CBYT     EQU      8
R9       EQU      9                 OPERAND TYPE
OTYP     EQU      9
R10      EQU      10                STATEMENT OPTIONS
STOP     EQU      10
R11      EQU      11                LINKAGE REGISTER
LNKR     EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         PAGE
*
COB31    EQU      START
START    LI,R7    1                 INITIALIZE
         LI,R6    2                 INDEX
         LI,R5    3                 REGISTERS
         LW,R13   LSN               IS THIS THE LAST PASS
         BNEZ     %+3               NO
         LI,R13   WA(WRCSF)         CHANGE ADDRESS OF CORRESPONDING
         STW,R13  CFILEOUT          OUTPUT FILE TO CSF
*        COMMON STARTING POINT FOR PROCESSING EACH EPF CLUSTER
CLIP     RES      0
         BAL,R11  RDEPF             GET NEXT CLUSTER ON EPF
         BLZ      PH31E             END OF FILE
*        INITIALIZE R3,R8,R9,R10 WITH FIELDS F2,B,F1,H
         LW,R1    R2
         AI,R1    1                 POINT TO CONTROL BYTE
         LB,CBYT  0,R1
         BNEZ     MCBYT
         LI,R13   BA(LINENTRY)      SAVE THIS CLUSTER
         BAL,R11  CLUBS             FOR DIAGNOSTICS AND REPORT TABLE
         LH,R13   LINENOS,UP1       COPY LINE NUMBER
         BEZ      NOCOPY            ZERO
         MTW,-1   LINENOS           DECREMENT COPY LINE NUMBER
PDBLINE  LW,R13   LINENOS           LINE NUMBER AND COPY LINE NUMBER
         STW,R13  CARDNO            STORE IN PDB
         B        COMX              OUTPUT TO THE CRF
NOCOPY   MTH,-1   LINENOS           DECREMENT LINE NUMBER
         B        PDBLINE           STORE IN PDB
MCBYT    LI,R13   X'80'             MASK OUT
         AND,R13  CBYT              HIGH ORDER BIT
         STB,R13  CLUNO,UP1         IF ON- FIRST CLUSTER OF STATEMENT
         EOR,CBYT R13               TURN OFF IN CONTROL BYTE IF ON
         CI,CBYT  X'78'             REPORT CLUSTER
         BL       EPFCL             NO
         BE       REPORT            PROCESS WITH NO EDITING
*        DATA RECORD,ETC.
         LW,R12   R2                MOVE LINE
         AI,R12   6                    NUMBER
         LI,R13   BA(LINENOS)          AND
         OR,R13   COUNT4               COPY LINE NUMBER
         MBS,R12  0                    TO XRF CLUSTER
         LW,R13   LINENOS           PUT IN
         STW,R13  CARDNO               PDB
EPFCL    CI,CBYT  X'58'             ENTER COBOL
         BE       CLIP              YES- BYPASS
         AI,R1    1                 POINT TO OPERAND OPTIONS
         LB,OTYP  0,R1              OPERAND OPTIONS INTO 27
         CI,CBYT  X'68'             SORT                                COBOL31
         BE       CRSOPT%0          YES.  COMBINE OPTIONS               COBOL31
EPFCL11  RES      0                                                     COBOL31
         CI,CBYT  X'55'
         BNE      EPFCL1            NOT DISPLAY
         CI,OTYP  0
         BNE      EPFCL1            NOT UPON PRINTER
         LI,R13   3
         STW,R13  DSPNTR            SET UPON PRINTER FLAG
         B        CLIP
EPFCL1   CI,OTYP  X'E5'
         BE       EPFCL2            YES ON SIZE ERROR
         CI,OTYP  X'E6'             IS IT ON OVERFLOW
         BNE      SPLIT             NO - GO ON
EPFCL2   LB,R14   ERSFLG,UP2        IS THE SPECIAL
         CI,R14   2                 ERRONEOUS STATEMENT FLAG ON
         BE       NOGO              YES- RESET FLAG AND DELETE STATEMENT
SPLIT    SLS,OTYP -4                SHIFT OFF REF TYPE
         LB,RTYP  0,R1              REFERENCE TYPE
         AND,RTYP L(X'F')
         AI,R1    1                 POINT TO STATEMENT OPTIONS
         STW,R1   VREGS
         LB,STOP  0,R1              STATEMENT OPTIONS INTO R9
         CI,OTYP  7                 ERRONEOUS STATEMENT
         BNE      ERSET             NO- CHECK ERS FLAG
         STB,RTYP ERSFLG,UP2        FLAG
CKFST    LB,R1    CLUNO,UP1         FIRST CLUSTER
         BEZ      CLIP              NO- BYPASS
         CI,CBYT  X'71'             'WHEN'
         BE       CLIP              YES- BYPASS
NOGO     LI,R1    BA(SAVBUF)        RESET SAVE
         STW,R1   SAVPTR            POINTER ADDRESS
         LI,R1    0                 RESET ERS
         STB,R1   ERSFLG,UP2        FLAG
         B        CLIP              BYPASS
REPORT   LI,R13   0                 PREVENT LAST OPERAND
         STB,R13  NEWS,UP2             BIT SETTING
         B        EPFCL+2
ERSET    LB,R1    ERSFLG,UP2        IS ERS FLAG ON
         BNEZ     CKFST             YES- CHECK IF FIRST CLUSTER
*        EXTRACT       CLUSTERS FOR SATISFACTION AND EDITING
*        PASS ALONG OTHERS UNCHANGED TO CRF
         CI,CBYT  X'59'
         BE       INEXM             EXAMINE
         CI,CBYT  X'4D'
         BE       INCHA             INSPECT
         CI,CBYT  X'4E'
         BNE      EXOTYP            NOT STRING
         AI,OTYP  0
         BNEZ     SSIZE1            NOT SYNTAX ONLY CLUSTER
         LW,R4    DDELM
         CI,R4    1
         BLE      SSIZE
         BAL,R11  WRT:DSUB          WRITE OUT DELIMITED SUBSCRIPTS      COBOL31
*                                    IF ANY EXIST                       COBOL31
         LI,R4    BA(DDELM)
         BAL,R11  WRCRF             OUTPUT DELIMITED DATA NAME TO CRF
SSIZE    LI,R4    1
         STW,R4   DDELM
         B        CLIP
SSIZE1   CI,OTYP  3
         BE       SDELM             FIGCON
         CI,OTYP  X'B'
         BE       SDELM             ANLIT STRING
EXOTYP   RES      0
         LW,R4    OTYP
         EXU      OTYBR,R4
PRFLAG   RES      0                                                     COBOL31
         CI,STOP  2                 MAY BE IN UNTIL OPTION OF PERFORM   COBOL31
         BNE      PRFLAG1           NO                                  COBOL31
         CI,CBYT  X'61'             IS IT IN PERFORM                    COBOL31
         BE       PRFRM             YES                                 COBOL31
PRFLAG1  RES      0                                                     COBOL31
         CI,STOP  1                 FLAG IN PERFORM                     COBOL31
         BNE      COMX
         CI,CBYT  X'5B'
         BNE      PRFLG1
         STW,STOP GOTODP            GO TO DEPENDING ON
         B        COMX
PRFLG1   CI,CBYT  X'61'
         BNE      COMX
         LB,R13   OJTJF,UP3         CHECK
         CI,R13   3                   IF MORE THAN 3
         BL       SETJT               VARYINGS
         LI,R1    X'88'
         BAL,R11  DIAG
         MTB,1    ERSFLG,UP2        SET BYPASS FLAG
         B        CLIP              READ NEXT
SETJT    MTB,1    JTJF,UP2          KEEP COUNT FOR PERFORM
         MTB,1    OJTJF,UP3         ACCUMULATIVE COUNT
COMX     LW,R4    R2                SET R4 TO ORIGINAL CLUSTER
         LI,R13   0                 INDICATE THIS
         STB,R13  WCHBUF,UP3        VIA WCHBUF
         BAL,R11  OCC               OUTPUT CLUSTER
         CI,CBYT  X'78'             DATA RECORDS,ETC ?
         BLE      CLIP              NO
         LI,R13   X'0400'           PUT OUT
         STH,R13  LINENTRY,UP1       A LINE NUMBER
         LI,R4    BA(CSFLINE)+2      CLUSTER
         BAL,R11  WRCRF              ON CRF
         B        CLIP              PROCESS NEXT CLUSTER
INLBL    CI,RTYP  2
         BE       %+3               BRANCH FALSE LABEL
         CI,RTYP  1                 BRANCH TRUE  LABEL
         BNE      TSTSZR
*        SAVE LABEL TO REPLACE MISSING OPERATORS
JJSAVE   LI,R13   BA(JTJFC)         SET RECEIVING REGISTER
         BAL,R11  CLUBS             GO MOVE CLUSTER
         LI,R4    BA(JTJFC)+3       TURN ON
         STB,UP1  0,R4                 IJFLAG FOR 4.1
         LI,R13   0                 TURN OFF
         STB,R13  SUBJECT,UP1          POSSIBLE SUBJECT FLAG
         B        COMX              OUTPUT AND EXIT
*        ROUTINE TO SAVE LABEL CLUSTERS - R13 ADDRESS OF SAVE AREA
CLUBS    RES      0
         LW,R12   R2                SHIFT COUNT INTO POSITION
         OR,R13   COUNT8            COUNT INTO RECEIVING REGISTER
         MBS,R12  0                 MOVE CLUSTER
         B        *R11              RETURN
TSTSZR   CI,RTYP  5                 IS IT 'ON SIZE ERROR'
         BE       TSTSO             YES
         CI,RTYP  6                 IS IT 'ON OVERFLOW'
         BNE      TSTRNG            NO
TSTSO    LI,R13   BA(ONSZR)         SET RECEIVING REGISTER
         BAL,R11  CLUBS             MOVE CLUSTER
         STB,UP1  SAVER             TURN ON ON SIZE ERROR FLAG
         B        COMX              OUTPUT AND EXIT
TSTRNG   CI,RTYP  9                 IS IT INTERNAL LABEL RANGE
         BNE      TSTDEF            CHECK IF DEF
         LW,R1    R2                GET CLUSTER ADDRESS
         AI,R1    4                 POINT TO RANGE NUMBER
         SLS,R1   -1                HALF WORD ADDRESS
         LH,R13   0,R1              MOVE RANGE NUMBER
         STH,R13  INLBR             TO SAVE LOCATION
         B        CLIP              PROCESS NEXT CLUSTER
*        IS THIS INTEGER AN OPERAND IN A PERFORM
PFOP     CI,RTYP  0                 IS IT AN OPERAND
         BNE      SUBIND            CHECK IF SUBSCRIPT
         BAL,R11  LOPRAND           CHECK IF LAST OPERAND
TSTPF    CI,CBYT  X'61'             IS IT IN PERFORM
         BNE      DIVISOR           CHECK IF IN ARITHMETIC
         B        PRFRM             EDIT
SUBIND   CI,RTYP  1                 IS IT A SUBSCRIPT
         BNE      INCDEC            INCREMENT OR DECREMENT
SUBCOM   CI,CBYT  X'78'             REPORT CLUSTER
         BE       COMX              YES- OUTPUT
         MTB,1    SUBS,UP1          INCREMENT NO. OF SUBSCRIPTS
INCDEC   CI,CBYT  X'56'             IS IT IN DIVIDE?
         BNE      %+4               CHECK IF IN GO TO
         LB,R13   BYTO,UP1          HAS 'BY OR 'INTO BEEN PROCESSED
         BNEZ     COMX              YES- DON'T SAVE
         B        SAVINT            SAVE IT
         CI,CBYT  X'5B'             IS IT IN GO TO
         BE       SAVINT            YES--GO SAVE IT                     COBOL31
         CI,CBYT  X'4E'             IS IT A STRING STATEMENT            COBOL31
         BE       INDEC2            YES                                 COBOL31
         CI,CBYT  X'4F'             IS IT A UNSTRING                    COBOL31
         BNE      TSTPF               NO--CHECK IF IN PERFORM           COBOL31
         MTW,0    INTO:FLG                                              COBOL31
         BGEZ     SAVINT            SAVE SUBSCRIPT/INDEX                COBOL31
         LI,R3    0                                                     COBOL31
         STW,R3   INTO:FLG          RESET FLG                           COBOL31
         LW,R3    SAVPTR                                                COBOL31
         STW,R3   PNTR1             SETUP POINTER                       COBOL31
         B        SAVINT            SAVE SUBS/INDEX                     COBOL31
INDEC2   EQU      %                                                     COBOL31
         MTW,0    INTO:FLG          ARE WE SAVING INTO/POINTER          COBOL31
*                                     SUBSCRIPTS                        COBOL31
         BEZ      SAVINT            BRANCH IF YES--COUNT #              COBOL31
         BGZ      PFSAVE            ALWAYS SAVE IF NOT FIRST TIME       COBOL31
*                                   AFTER THE INTO CLUSTER              COBOL31
         MTW,1    SAVPTR            BUMP POINTER BY ONE SO THERE WILL   COBOL31
*                                   BE A BYTE OF ZERO AFTER THE INTO/   COBOL31
*                                   POINTER SAVED CLUSTERS              COBOL31
         LW,R3    SAVPTR                                                COBOL31
         STW,R3   PNTR1             SAVE START OF DELIM SAVE            COBOL31
         STW,R3   PNTR2                                                 COBOL31
         STW,R3   INTO:FLG          SET INTO FLAG FOR NOT FIRST TIME    COBOL31
         B        PFSAVE            GO SAVE THE CLUSTERS                COBOL31
*                                                                       COBOL31
SAVINT   MTW,1    SAVER
         B        PFSAVE            SAVE CLUSTER
*        RELATIONAL OPERATOR
*        REPLACE WITH LAST JUMP TRUE/FALSE CLUSTER IF
*        MISSING  LOGICAL OPERATOR
RELOP    CI,RTYP  8                 MISSING OPERATOR FLAG
         BNE      RELOP1            NO CHECK IF NEGATED
         LI,R4    BA(JTJFC)         SET OUTPUT REGISTER TO JTJFC
ONEX     LI,R13   X'0F'             ONLY ONE
         STB,R13  WCHBUF,UP3        CLUSTER
         BAL,R11  OCC               OUTPUT SAVED CLUSTER
         LI,R13   0                 TURN OFF
         STB,R13  SUBJECT,UP1          SUBJECT FLAG
         B        CLIP              PROCESS NEXT CLUSTER
RELOP1   BAZ      SUBSET            NEGATION BIT ON - NO
         LW,R1    R2                PICK UP
         AI,R1    2                    OPERAND OPTIONS
         MTB,-1   0,R1              ADJUST TO MAKE 8 COMPLEMENT OF 0-2
SUBSET   STB,UP1  SUBJECT,UP1       TURN ON SUBJECT FLAG
         B        COMX
         PAGE
*        COMMON ENTRY POINT FOR ALL REFERENCE CLUSTERS
*        BUILD COMPOSITE CLUSTERS FOR DATA AND PROCEDURE REFERENCES
*        CONTAINING REFERENCE NUMBERS OF QUALIFIERS IN MAJOR TO MINOR
*        ORDER BEFORE ATTEMPTING REFERENCE SATISFACTION
REFSAT   RES      0
         EXU      RTYTAB,RTYP       GO TO BRANCH TABLE
PARDEF   LH,R1    NUMBERS,UP1       SAVED SECTION NO - R1
         LW,R4    CPTR              STORE
         OR,R1    QBIT              TURN ON QUALIFIER BIT
         STH,R1   0,R4                  IN CLIST
         AWM,UP1  CPTR              INCREMENT CLIST POINTER
         BAL,R11  BUILD00           BUILD COMPOSITE CLUSTER
*  THE FOLLOWING 11 LINES OF CODE STORE THE INTERNAL LABEL              COBOL31
*    COUNT IN THE CLUSTER FOR UNSATISFIED PROCEDURE DEFINITIONS         COBOL31
         BAL,R11  GETDEF            RESOLVE                             COBOL31
         LW,R4    R2                                                    COBOL31
         AI,R4    2                                                     COBOL31
         LB,R13   0,R4              PICK UP OPERAND OPTIONS BYTE        COBOL31
         CI,R13   X'89'             IS DEFINITION SATISFIED             COBOL31
         BNE      PROCDF+1          YES                                 COBOL31
         AI,R4    -2                POINT TO BEGINNING OF CLUSTER       COBOL31
         SLS,R4   -1                HW ADDRESS                          COBOL31
         LH,R13   INLBR             GET NO OF INTERNAL LABELS           COBOL31
         STH,R13  2,R4              PUT IN CLUSTER                      COBOL31
         B        PROCDF+1          CONTINUE                            COBOL31
PROCDF   BAL,R11  GETDEF            RESOLVE
         LI,R13   0                 INITIALIZE
         STH,R13  INLBR                 INT. LABEL RANGE
         B        COMX              OUTPUT AND EXIT
SECTLR   LW,R1    R2              PICK UP
         AI,R1    2                   OPERAND OPTIONS
         LI,R13   X'9A'           CHANGE TO
         STB,R13  0,R1                TYPE 9
         AI,R1    2               PICK
         SLS,R1   -1                   UP
         LH,R13   0,R1            REFERENCE NUMBER
         STH,R13  NUMBERS,UP1     STORE IN SECNO
         B        COMX              OUTPUT AS IS
PRONAM   RES      0                 PROCEDURE NAME
         BAL,R11  RSGOP
         BAL,R11  ENTER
         BAL,R11  CLIMB             QUALIFY AND RESOLVE
         BAL,R11  LOPRAND           PR. NAME LAST OPERAND
         LB,R1    CLUNO,UP1         FIRST CLUSTER OF STATEMENT
         BEZ      ALTER             CHECK ALTER
         CI,CBYT  X'61'             IS IT IN PERFORM
         BNE      COMX              OUTPUT
         LB,R13   OJTJF,UP3         NUMBER OF VARYINGS IN PERFORM
         BEZ      NOVAR             NO VARYINGS
         LW,R1    R2                PICK UP
         AI,R1    3                     STATEMENT OPTIONS
         STB,R13  0,R1              PLUNK IN VARY COUNT
         LI,R13   0                 ZERO OUT
NOVAR    STH,R13  JTJF,UP1          ZERO OUT COUNTS
         B        COMX              OUTPUT
RSGOP    CI,CBYT  X'5B'
         BNE      *R11              NOT GO TO
         LB,R13   CLUNO,UP1
         BEZ      *R11              NOT FIRST CLUSTER
         MTW,0    GOTODP
         BEZ      *R11              NOT DEPENDING ON
         XW,R1    VREGS
         LI,STOP  0
         STW,STOP GOTODP            CLEAR GO TO DEPENDING ON FLAG
         STB,STOP 0,R1
         XW,R1    VREGS
         B        *R11
ALTER    CI,CBYT  X'52'             IS IT IN ALTER TO PROCEED TO
         BNE      COMX              NO- OUTPUT
         CI,STOP  0                 IS IT PROCEED TO
         BNE      SAVINT            YES- SAVE IT
         LI,R13   X'80'             TURN ON
         STB,R13  CLUNO,UP1            FIRST CLUSTER BIT
         LW,R1    R2                ACCESS
         AI,R1    1                    CONTROL BYTE
         LB,R13   0,R1              TURN ON
         AI,R13   X'80'                FIRST CLUSTER
         STB,R13  0,R1                 BYTE
         B        COMX              OUTPUT
PARANM   RES      0                 PARAMETER NAME
         BAL,R11  ENTER
         BAL,R11  CLIMB             QUALIFY AND RESOLVE
         B        LOPOUT            CHECK IF LAST OPERAND AND EXIT
SUBSC    BAL,R11  CLIMB             SUBSCRIPT DATA NAME
         B        SUBCOM            CHECK IF SIGNIFICANT
         PAGE
DANAM    RES      0                 DATA NAME ENTRY
         BAL,R11  ENTER
         BAL,R11  CLIMB             QUALIFY AND RESOLVE
         BAL,R11  LOPRAND           IS NAME LAST OPERAND
         CI,CBYT  X'78'             IS IT SOURCE SELECTED
         BE       COMX              YES- FINISHED
         LB,R13   SUBS,UP1          NUMBER OF SUBSCRIPTS
         SLS,R13  5                 SHIFT TO BITS 1 AND 2
         CI,CBYT  X'74'
         BL       DANAM1            NOT CORRESPONDING
         CI,CBYT  X'76'
         BG       DANAM1            NOT CORRESPONDING
         OR,R14   R13
         STB,R14  0,R1              SET SUBSCRIPT BITS
         B        DANAM2
DANAM1   RES      0
         LB,R4    1,R2
         OR,R13   R4
         STB,R13  1,R2              SET SUBSCRIPT NUMBER
DANAM2   STB,R15  SUBS,UP1          ZERO NUMBER OF SUBSCRIPTS
         CI,CBYT  X'61'             IS IT IN PERFORM
         BE       PRFRM             YES- GO EDIT
         CI,CBYT  X'5B'             IS IT IN GO TO DEPENDING ON
         BE       SAVINT
         CI,CBYT  X'4E'             STRING
         BE       SUPNT
         CI,CBYT  X'4F'             UNSTRING
         BE       SUTAL
         CI,CBYT  X'4C'                                                 COBOL31
         BG       DIVISOR                                               COBOL31
         AI,R2    2                                                     COBOL31
         LB,R4    0,R2              OPRND TYPE                          COBOL31
         AI,R2    -2                                                    COBOL31
         CI,R4    X'80'                                                 COBOL31
         BE       COMX              UNDEFINED DATA                      COBOL31
         CI,CBYT  X'4C'                                                 COBOL31
         BE       DANAM4            CALL                                COBOL41
         CI,CBYT  X'4B'                                                 COBOL31
         BNE      COMX                                                  COBOL31
         LB,R4     2,R2               BASE OF LINKAGE                   COBOL31
         CI,R4     X'FF'                                                COBOL31
         BNE      DANAM5            ERROR - NOT IN LINKAGE              COBOL31
DANAM4   LW,R4    DPONTR            DDD POINTER                         COBOL31
         SLS,R4   2                 TO BYTE ADDR                        COBOL31
         LB,R4    2,R4              LEVEL NUMBER                        COBOL31
         CI,R4    1                                                     COBOL31
         BE       COMX              IS 01                               COBOL31
         CI,R4    77                                                    COBOL31
         BE       COMX              IS 77                               COBOL31
DANAM5   LI,R1    93                                                    COBOL31
         BAL,R11  DIAG              BAD DATA USAGE                      COBOL31
         B        COMX                                                  COBOL31
         PAGE                                                           COBOL31
*                                                                       COBOL31
*        SUBROUTINE TO COMBINE SORT OPTIONS INTO LAST CRF               COBOL31
*                                                                       COBOL31
CRSOPT%0 RES      0                                                     COBOL31
         AI,R1    1                                                     COBOL31
         LB,R4    0,R1              STATEMENT OPTION                    COBOL31
         CI,R4    8                 I/O PROCEDURE                       COBOL31
         BL       CRSOPT%2          NO CONTINUE                         COBOL31
         CI,R4    X'10'             USING OR INPUT PROCEDURE            COBOL31
         BLE      CRSOPT%1          NO                                  COBOL31
         STW,R4   SAVE%1            SAVE STATEMENT OPTION               COBOL31
         B        CRSOPT%2                                              COBOL31
CRSOPT%1 RES      0                                                     COBOL31
         OR,R4    SAVE%1            COMBINE STATEMENT OPTIONS           COBOL31
         STB,R4   0,R1              IN CRF                              COBOL31
CRSOPT%2 RES      0                                                     COBOL31
         AI,R1    -1                                                    COBOL31
         B        EPFCL11                                               COBOL31
SAVE%1   DATA     0                 STATEMENT OPTION                    COBOL31
         PAGE
DVFRST   RES      0
         LI,R13    0                                                    COBOL31
         STB,R13  BYTO,UP1          TURN OFF BY, INTO FLAG
         LW,R4    REMF              SEE REMAINDER USED INCORECTLY       COBOL31
         BEZ      DVFRST1           OK                                  COBOL31
         STW,R13  REMF              BAD-RESET AND ISSUE DIAG            COBOL31
         LI,R1    43                                                    COBOL31
         BAL,R11  DIAG                                                  COBOL31
DVFRST1  RES      0                                                     COBOL31
         B        COMX              OUTPUT
FLSH     STW,R11  NESTRET2
         LH,R14   SAVER,UP1         ANYTHING SAVED BESIDES ON SIZE ERROR
         BEZ      *R11              NO- RETRN
         LI,R13    0                                                    COBOL31
         STH,R13  SAVER,UP1         ZERO OUT SAVER
         LI,R14   X'F0'             SET UP
         STB,R14  WCHBUF,UP3           OUTPUT
         LI,R4    BA(SAVBUF)              OF SAVE AREA
         STW,R4   SAVPTR             INITIALIZE SAVE INDEX
         BAL,R11  OCC               WRITE SAVED CLUSTERS
         B        *NESTRET2         RETURN
FLSH2    EQU      %                                                     COBOL31
         STW,R11  NESTRET2          SAVE RETURN                         COBOL31
         LI,R11   X'F0'             FLUSH WHOLE BUFFER                  COBOL31
         STB,R11  WCHBUF,UP3                                            COBOL31
         BAL,R11  OCC               WRITE IT OUT                        COBOL31
         B        *NESTRET2         AND RETRN                           COBOL31
DIVISOR  CI,CBYT  X'56'             IS IT IN DIVIDE
         BNE      SUBTRACT          CHECK IF IN SUBTRACT
         CI,STOP  X'10'
         BAZ      DIVIS1
         MTW,1    REMF              WITH REMAINDER
         LW,R4    R2
         AI,R4    3
         LB,R13    0,R4                                                 COBOL31
         AND,R13   L(X'EF')                                             COBOL31
         STB,R13  0,R4              RESET TO GIVING OPERAND
         AND,STOP  L(X'EF')                                             COBOL31
DIVIS1   CI,STOP  2
         BL       DINTO             CHECK IF DIVIDE INTO
         BE       DIVGIV            GIVING - FLUSH SUBSCRIPTS - SET FLAG
         CI,STOP  8
         BNE       DINTOZ                                               COBOL31
*        DIVIDE BY- ZERO OUT STATEMENT OPTIONS AND SAVE CLUSTER
DIVBY    LW,R4    R2                PICK UP
         AI,R4    3                     STATEMENT OPTIONS
         STB,R13  GIVER                                                 COBOL31
         LB,R13   0,R4              TURN OFF LAST                       COBOL31
         AND,R13  L(X'0000007F')    STATEMENT INDICATOR                 COBOL31
         STB,R13  0,R4              OF STATEMENT OPTIONS BYTE           COBOL31
         MTB,1    BYTO,UP1
         B        SAVINT            SAVE CLUSTER
DINTO    CI,STOP  1                 IS IT DIVIDE INTO
*                 SIDR 1182
*                 DIAGNOSTICS: 096 INVALID DATA REF
*                              165 INVALID SUBSCRIPT INDEXES
         BE        DINTOZ-1                                             COBOL31
         LB,R11   CLUNO,UP1                                             COBOL31
         BNEZ     DVFRST
         B         DINTOZ                                               COBOL31
         MTB,1    BYTO,UP1          TURN ON BY, INTO FLAG
DINTOZ   BAL,R11  FLSH                                                  COBOL31
         B        SUBDIV
DIVGIV   RES      0                 GIVING- WRITE OUT SUBS. AND SET FLAG
         MTW,0    REMF
         BEZ      DIVGV1            NO REMAINDER
         MTW,-1   REMF              RESET REMAINDER FLAG
         LW,R4    R2
         SLS,R4   -1
         AI,R4    1
         LH,R13   0,R4
         OR,R13   L(X'10')          SET REMAINDER FLAG
         STH,R13  0,R4
DIVGV1   RES      0
         BAL,R11  FLSH
         B        GIVING
SUBTRACT CI,CBYT  X'6A'             IS IT IN SUBTRACT
         BNE      MLTPLY            NO - CHECK IF MULTIPLY
         CI,STOP  2                 IS IT GIVING
         BE       GIVING            YES- SET FLAG FOR 'FROM' OPERAND
         CI,STOP  1                 IS IT 'FROM'
         BNE      COMX
SUBDIV   LB,R13   GIVER             IS GIVING FLAG ON
         BEZ      COMX              NO- OUTPUT THIS CLUSTER
         LI,R13   0                 INITIALIZE
         STB,R13  GIVER                'GIVING' FLAG
         LW,R1    R2                ACCESS
         AI,R1    3                    STATEMENT OPTIONS
         LB,R13   0,R1              ZERO OUT
         AND,R13  L(X'000000F0')       LOW ORDER BITS
         STB,R13  0,R1              REPLACE WITH NEW BYTE
         B        COMX              OUTPUT
GIVING   STB,UP1  GIVER             TURN ON 'GIVING' FLAG
         B        COMX              OUTPUT AND RETURN
ENTER    CI,CBYT  X'57'
         BNE      *R11
         MTB,1    ENTCNT,UP2
         B        *R11
MLTPLY   CI,CBYT  X'5F'             IS IT IN MULTIPLY
         BE       SUBTRACT+2        YES, EDIT AS SUBTRACT       EL27975 COBOL31
         CI,CBYT  X'7D'             IS SELECT A FILE NAME ?     EL27975 COBOL31
         BE       CLIP              YES, NO CRF OUTPUT          EL27975 COBOL31
XIBIT    LB,R13   PSFLAG,UP3        HAS NAME STRING BEEN SAVED
         BEZ      COMX              NO - OUTPUT
         LW,R1    R2                PICK UP
         AI,R1    2                 REFERENCE TYPE
         LB,R13   0,R1
         CI,R13   X'92'
         BE       COMX              SUBSCRIPTED DATA NAME
         CI,R13   X'D1'
         BE       COMX
*  SIDR 6222 CHECK FOR INDEX INCREMENT OR DECREMENT                     COBOL31
         CI,R13    X'D2'           INCREMENT                            COBOL31
         BE        COMX                                                 COBOL31
         CI,R13    X'D3'           DECREMENT                            COBOL31
         BE        COMX                                                 COBOL31
         CI,R13   X'82'          UNRESOLVED SUB DATA NAME               COBOL31
         BE       COMX                                                  COBOL31
         STB,R15  PSFLAG,UP3        TURN OFF SAVE FLAG
         LB,R13   CLUNO,UP1         IS IT FIRST CLUSTER
         BEZ      XIBIT1
         LI,R13   X'F'
         AND,R13  STOP
         LI,R1    BA(SAVBUF)+3
         LB,R14   0,R1
         OR,R14   R13
         STB,R14  0,R1
         MTW,1    SAVER             FLIP THIS WITH
         B        COMX                 SAVED CLUSTER
XIBIT1   RES      0
         LW,R4    R2                WRITE OUT CURRENT
         LI,R13   0
         STB,R13  WCHBUF,UP3
         BAL,R11  OCC
         LI,R13   X'F'              FLAG- ONE SAVED CLUSTER
         STB,R13  WCHBUF,UP3        SAVE BUFFER
         LI,R4    BA(SAVBUF)        R4 TO BUFFER
         STW,R4   SAVPTR            INITIALIZE POINTER
         B        COMX+3            OUTPUT SAVED STRING AND EXIT
*
*  DATA MANIPULATION PROCESSOR
*      EXAMINE, INSPECT, STRING AND UNSTRING
*
INCHA    LI,R4    4
         AND,R4   STOP
         AI,OTYP  0
         BNEZ     INCHA1            NOT SYNTAX ONLY CLUSTER
         STW,R4   INCHF             SAVE STATEMENT OPTION
         B        CLIP
INCHA1   MTW,0    INCHF
         BEZ      INEXM
         OR,STOP  INCHF             COMBINE STOP
         LW,R4    VREGS
         STB,STOP 0,R4              COMBINE STOP
         LI,R4    0
         STW,R4   INCHF
INEXM    MTB,0    CLUNO,UP1
         BEZ      INEXM1            NOT FIRST CLUSTER OF STATEMENT
         LI,R4    0
         XW,R4    TLRPF             RESET TLRPF
         OR,STOP  R4
         LW,R4    VREGS
         STB,STOP 0,R4              COMBINE STOP OF TALLYING/REPLACING
         B        EXOTYP
INEXM1   LI,R4    X'60'
         AND,R4   STOP              STOP OF TALLYING/REPLACING
         OR,R4    TLRPF
         STW,R4   TLRPF
         B        EXOTYP
SUPNT    CI,STOP  X'08'
         BANZ     SUPNT1            POINTER
         CI,STOP  X'04'
         BAZ      SDELM             NOT INTO
         MTW,-1   INTO:FLG          SET FLAG TO INDICATE WE GOT AN INTO COBOL31
         MTB,0    SAVER
         BNEZ     SUPNT1            WITH 'ON OVERFLOW'-SAVE INTO
         LW,R4    R2
         AI,R4    1
         LB,R14   0,R4
         OR,R14   L(X'80')          TURN ON FIRST CLUSTER BIT
         STB,R14  0,R4
         B        SUPNT1            SAVE INTO
SDELM    CI,STOP  X'01'
         BANZ     SDELM2            DELIMITED DATA-NAME
         LW,R4    DDELM
         BDR,R4   SDELM1            NOT DELIMITED SIZE
         LW,R4    R2
         AI,R4    3
         LB,R14   0,R4              STMT OPTION
         OR,R14   L(X'02')
         STB,R14  0,R4              SET SIZE OPTION
         BAL,R11  LOPRAND           FOR LAST OPERAND
         BAL,R11  WRT:ISUB          WRITE IDENTIFIER SUBSCRIPTS IF ANY  COBOL31
         B        COMX
SDELM1   EQU      %                                                     COBOL31
         BAL,R11  WRT:ISUB          WRITE IDENT SUBSCRIPTS IF ANY       COBOL31
         BAL,R11  LOPRAND                                               COBOL31
         MTB,0    CLUNO,UP1                                             COBOL31
         BEZ      COMX              NOT LAST ENTRY                      COBOL31
         LW,R4    R2                WRITE CURRENT CLUSTER
         BAL,R11  WRCRF
         BAL,R11  WRT:DSUB          WRITE DELIM SUBSCRIPTS IF ANY       COBOL31
         LI,R2    BA(DDELM)         SAVED DELIMITED DATA-NAME
         B        COMX
SDELM2   LW,R4    DDELM
         CI,R4    1
         BLE      SDELM3            NO DATA NAME SAVED
         BAL,R11  WRT:DSUB          WRITE DELIM SUBSCRIPTS IF ANY       COBOL31
         LI,R4    BA(DDELM)
         BAL,R11  WRCRF             DELIMITED DATA-NAME TO CRF
         B        SDELM4            BYPASS FIRST TIME SET UP            COBOL31
SDELM3   EQU      %                                                     COBOL31
         LW,R1    SAVPTR            SET UP PNTR1 AND PNTR2              COBOL31
         CW,R1    PNTR1             SEE IF ANY SUBSCRIPTS SAVED         COBOL31
         BE       SDELM31           NO--DO NOT CHG SAVPTR               COBOL31
         AI,R1    1                 CHG LOADED VALUE OF SAVPTR          COBOL31
         MTW,1    SAVPTR            BUMP SAVPTR BY ONE FOR X'00'        COBOL31
SDELM31  EQU      %                                                     COBOL31
         MTW,0    INTO:FLG          SEE IF WE GOT SUB ON DELIM          COBOL31
         BGZ      SDELM3A           WE GOT THEM                         COBOL31
         STW,R1   PNTR1                                                 COBOL31
SDELM3A  EQU      %                                                     COBOL31
         STW,R1   PNTR2                                                 COBOL31
SDELM4   EQU      %                                                     COBOL31
         LB,R1    0,R2                                                  COBOL31
         AW,R1    R1
         LI,R3    BA(DDELM)
         STB,R1   R3                BYTE LENGTH
         MBS,R2   0                 SAVE DELIMITED DATA-NAME
         LI,R1    X'80'
         AND,R1   DDELM
         BEZ      CLIP              NOT LAST OPERAND
         STB,R1   NEWS,UP2          TURN ON LAST OPERAND BIT
         EOR,R1   DDELM
         STW,R1   DDELM             REMOVE LAST OPERAND BIT
         B        CLIP
SUTAL    CI,STOP  X'48'             TALLYING OR POINTER
         BANZ     SUPNT0            SAVE POINTER/TALLY CLUSTER          COBOL31
         LI,R4    BA(SAVBUF)                                            COBOL31
         MTW,0    PNTR2             DID WE HAVE POINTER/TALLY           COBOL31
         BEZ      SUTAL2A           BRANCH IF NOT                       COBOL31
         MTB,0    CLUNO,UP1         SEE IF LAST CLUSTER                 COBOL31
         BEZ      SUTAL2            BRANCH IF NOT LAST                  COBOL31
         LW,R4    PNTR1             GET END                             COBOL31
         BEZ      SUTAL1            IF ZERO DONT NED X'00'              COBOL31
         LI,R13   0                                                     COBOL31
         LB,R11   0,R4              GET FOLLOWING CLUSTER SIZE          COBOL31
         STB,R13  0,R4              SET BYTE TO X'00' TO STOP WRITE     COBOL31
         STB,R11  STRNGSAV          SAVE LENGTH                         COBOL31
SUTAL1   EQU      %                                                     COBOL31
         LI,R4    BA(SAVBUF)                                            COBOL31
         BAL,R11  FLSH2             WRITE OUT SAVED POINTER/TALLY       COBOL31
         LW,R4    PNTR1                                                 COBOL31
         BEZ      SUTAL2            IF ZERO CONTINUE                    COBOL31
         LB,R11   STRNGSAV                                              COBOL31
         STB,R11  0,R4              RESET SIZE                          COBOL31
SUTAL2   EQU      %                                                     COBOL31
         MTW,0    INTO:FLG                                              COBOL31
         BLZ      SUTAL3            IF LESS NO SUBSCRIPTS               COBOL31
         LW,R4    PNTR1             SEE IF ITS ZERO                     COBOL31
         BEZ      SUTAL3            BRANCH IF NO SUBSCRIPTS             COBOL31
SUTAL2A  RES      0                                                     COBOL31
         CW,R4    SAVPTR            SEE IF THE ARE THE SAME             COBOL31
         BE       SUTAL3            BRANCH IF THE ARE                   COBOL31
         STW,R4   SAVPTR            RESET THE POINTER                   COBOL31
         BAL,R11  FLSH2             WRITE OUT THE SUBSCRIPTS            COBOL31
SUTAL3   EQU      %                                                     COBOL31
         MTB,0    CLUNO,UP1                                             COBOL31
         BEZ      COMX              IF NO SUBSCRIPTS GET OUT            COBOL31
         BAL,R11  STRCLEAR          CLEAR FLAG ON LAST CLUSTER          COBOL31
         LI,R4    BA(SAVBUF)        RESET SAVPTR                        COBOL31
         STW,R4   SAVPTR            RESET SAVE POINTER                  COBOL31
         B        COMX              OUTPUT AND RETURN
SUPNT0   EQU      %                                                     COBOL31
         MTW,-1   INTO:FLG          SET FLG FOR POSSIBLE SUBS           COBOL31
         MTW,1    PNTR2             SET FLAG INDICATING WE GOT TALLY OR PNT
SUPNT1   LW,R4    R2
         AI,R4    3
         LB,R14   0,R4              STATEMENT OPTION
         CI,R14   X'80'
         BAZ      SAVINT            NOT LAST OPERAND
         LI,R13   X'80'
         STB,R13  NEWS,UP2          TURN ON LAST OPERAND BIT
         AND,R14  L(X'7F')          REMOVE LAST OPERAND BIT
         STB,R14  0,R4
         B        SAVINT
*                                                                       COBOL31
*                                                                       COBOL31
*                                                                       COBOL31
WRT:DSUB EQU      %                                                     COBOL31
         STW,R11  STRNGSAV          SAVE RETURN                         COBOL31
         LW,R4    PNTR1             PICK UP POINTER ONE                 COBOL31
         CW,R4    PNTR2             COMPARE IT WITH POINTER 2           COBOL31
         BE       *STRNGSAV         IF THERE THE SAME WE DONT HAVE ANY  COBOL31
*                                   SUBSCRIPTS TO WRITE                 COBOL31
         BAL,R11  FLSH2             FLSH WHAT WE GOT                    COBOL31
         LW,R14   SAVPTR            GET CURRENT POINTER                 COBOL31
         SW,R14   PNTR2             DO WE NEED TO MOVE NEW SUBSRIPTS    COBOL31
*                                   DOWN TO HLOD AREA ONE               COBOL31
         BEZ      *STRNGSAV         GET OUT IF NOT                      COBOL31
         AI,R14   1                 INCREASE COUNT BY ONE               COBOL31
         LW,R15   PNTR1             GET DESTINATION                     COBOL31
         STB,R14  R15               SET COUNT                           COBOL31
         LW,R14   PNTR2             GET SOURCE ADDRSSS                  COBOL31
         MBS,R14  0                                                     COBOL31
         AI,R14   1                 POINT FORWARD ONE BYTE              COBOL31
         STW,R14  SAVPTR            SET NEW SAVE ADDRESS                COBOL31
         STW,R14  PNTR2             IN BOTH PINTERS                     COBOL31
         B        *STRNGSAV         GET OUT                             COBOL31
*                                                                       COBOL31
*                                                                       COBOL31
WRT:ISUB EQU      %                                                     COBOL31
         STW,R11  STRNGSAV          SAVE RETURN                         COBOL31
         LW,R4    R2                GET CLUSTER ADDRESS                 COBOL31
         AI,R4    1                 POINT TO THE CBYT                   COBOL31
         LI,R11   X'4E'             AND MAKE SURE HIGH BIT IS OFF       COBOL31
         STB,R11  0,R4                                                  COBOL31
         LW,R4    PNTR2             SEE IF ANY SUBSCRIPTS               COBOL31
         BEZ      *STRNGSAV         NO SUBS                             COBOL31
         CW,R4    SAVPTR                                                COBOL31
         BE       *STRNGSAV         BRANCH IF NO SUBSCRIPTS             COBOL31
         BAL,R11  FLSH2             FLUSH WHAT WE GOT                   COBOL31
         LW,R4    PNTR2             RESET SAVPRT                        COBOL31
         STW,R4   SAVPTR                                                COBOL31
         B        *STRNGSAV         AND GET OUT                         COBOL31
*                                                                       COBOL31
*                                                                       COBOL31
         PAGE
TSTDEF   CI,RTYP  X'8'              IS IT DEFINITION
         BNE      COMX              NO
         CI,STOP  X'65'             IN SEARCH
         BNE      COMX              NO
         LI,R13   BA(ENDSV)         ANYTHING
         CW,R13   SAVPTR                SAVED
         BNE      COMX              NO- OUTPUT
         B        SAVINT            SAVE CLUSTER
STRING   CI,CBYT  X'70'             IN EXHIBIT
         BNE      LOPOUT            NO
         CI,STOP  8                 IS IT NAME
         BAZ      LOPOUT               OPTION
         MTB,1    PSFLAG,UP3        TURN ON SAVE FLAG
         B        PFSAVE            SAVE CLUSTER
         PAGE
*        ROUTINE TO BUILD COMPOSITE CLUSTER INSERTING REFERENCE
*        NUMBERS AHEAD OF THAT FOR NAME.
*        R2 RESET TO BYTE ADDRESS OF NEW CLUSTER.
BUILD00  LI,R4    0
CCBUILD  RES      0
         LW,R14   R2                ORIGINAL CLUSTER- SOURCE REGISTER
         LB,R13   0,R2              SAVE ORIGINAL CLUSTER LENGTH
         LI,R15   BA(NEWCL)         NEW CLUSTER-- DeSTIN. REGISTER
         OR,R15   COUNT4            MOVE FOUR
         MBS,R14  0                 BYTES
         LW,R15   CPTR              NEXT HW LOCATION IN CLIST
         AI,R13   -2                DECREMENT CL. LENGTH BY 2 HALF WDS.
         STB,R13  R15               SET UP COUNT FIELD DESTINATION REG.
         AW,R15   R15               SHIFT TO BYTE ADDRESSING
         AW,R14   R4                SKIP/DON'T SKIP REF #
         MBS,R14  0                 MOVE TAIL END OF CLUSTER
         LI,R2    BA(NEWCL)         CHANGE R2 TO NEW CLUSTER
         SW,R15   R2                CALCULATE NEW CLUSTER LENGTH
         SLS,R15  -1                HA
         STB,R15  0,R2              STORE IN NEW CLUSTER
         LI,R13   HA(CLIST)         INITIALIZE
         STW,R13  CPTR              NEXT CLIST POINTER
         B        *R11              RETURN
         PAGE
QUALIF   RES      0
         LW,R1    R2                ADDRESS OF CLUSTER
         SLS,R1   -1                HA
         AI,R1    2                 POINT TO REFERENCE NUMBER
         LH,R13   0,R1              PUT REFERENCE NUMBER
         OR,R13   QBIT              TURN ON HIGH ORDER BIT FOR QUALIFIER
         LW,R4    CPTR              STORE REFERENCE NUMBER
         STH,R13  0,R4              IN NEXT LOCATION IN CLIST
         AWM,UP1  CPTR              NEXT CLIST ADDRESS
         B        CLIP              PROCESS NEXT CLUSTER
CLIMB    STW,R11  OCCR              SAVE RETURN
         LI,R1    HA(CLIST)         CHECK FOR
         CW,R1    CPTR              ANY QUALIFICATION
         BE       REVOLT            NONE- GO AND RESOLVE
         BAL,R11  BUILD00           YES-BUILD NEW CLUSTER
REVOLT   BAL,R11  GETDEF            RESOLVE REFERENCE
         B        *OCCR             RETURN
EXTREF   LW,R1    R2                ACCESS
         AI,R1    2                     OPERAND OPTIONS
         MTB,4    0,R1              CHANGE TO 'A4'
         LB,R13   ENTCNT,UP2        PUT COUNT
         AI,R1    1                     OF PARAMETERS
         STB,R13  0,R1              INTO STATEMENT OPTIONS
         LI,R13   0                 INITIALIZE
         STB,R13  ENTCNT,UP2           COUNTER
         LB,R13   0,R2              CLNG
         AI,R13   5                 ADJUST LENGTH
         SLS,R13  8
         AI,R13   5                 TYPE CODE FOR TRUE EXTERNAL
         LI,R14   COMX              RETURN ADDRESS
         STW,R14  NESTRET2            INTO RET2
         AI,R1    1                 R1 TO NAME LENGTH
         LI,R15   BA(XNAME)
         LB,R14   0,R1              LENGTH
         AI,R14   1                    +1
         STB,R14  R15               TO DESTINATION REGISTER
         LW,R14   R1                ADDRESS OF NAME LENGTH
         MBS,R14  0                 MOVE TO XRF CLUSTER
         B        XRFDENT-2         PUT OUT ON XRF IF NECESSARY
         PAGE
*        JUMP TABLES
*        REFERENCE TYPE PROCESSING
RTYTAB   B        DANAM             0   DATA NAME
         B        QUALIF            1   QUALIFIER
         B        SUBSC             2   DATA SUBSCRIPT
         B        QUALIF            3   SUBSCRIPT QUALIFIER
         B        PRONAM            4   PROCEDURE NAME
         B        QUALIF            5   PROCEDURE QUALIFIER
         B        PARANM            6   PARAMETER NAME
         B        QUALIF            7   PARAMETER QUALIFIER
         B        PROCDF            8   SECTION DEFINITION
         B        PARDEF            9   PARAGRAPH DEFINITION
         B        SECTLR            A   SECTION TRAILER
         B        COMX              DEBUG NAME                          COBOL31
         B        COMX              DEBUG NAME                          COBOL31
         B        BADIN             D   UNASSIGNED
         B        BADIN             E   UNASSIGNED
         B        BADIN             F   UNASSIGNED
BADIN    RES      0
         LI,R1    513
         BAL,R11  DIAG              COMPILER ERROR 13
         B        CLIP
*        OPERAND TYPE PROCESSING
OTYBR    B        PRFLAG            SYNTAX ONLY
         B        COMX              ARITHMETIC OPERATOR
         B        RELOP             RELATIONAL OPERATOR
LOPOUT   BAL,R11  LOPRAND           FIG. CONSTANT- CHECK IF LAST OPERAND
         B        COMX
         B        COMX
         B        COMX
         B        CLIP
         B        REFSAT            NAME REFERENCE
         B        COMX
         B        EXTREF            EXTERNAL REFERENCE
         B        STRING            STRING
         B        TSTPF-1           NUMBER
         B        PFOP              INTEGER
         B        INLBL             INTERNAL LABEL
         PAGE
*        PRFRM SUBROUTINE - REARRANGES ORDER OF FORM 4 PERFORM
*        STATEMENTS SO THAT VARYING CLAUSES APPEAR AHEAD OF
*        CONDITIONS
PFOUT    EQU      COMX
PRFRM    LI,R15   0
         LI,R13   1                 MORE THAN
         CB,R13   OJTJF,UP3             ONE VARYING
         BGE      COMX              NO- OUTPUT CLUSTER
         CI,STOP  2                 IS IT UNTIL
         BNE      VARBYFR           NO- CHECK IF VARYING,BY, OR FROM
         STB,R13  PSFLAG,UP3        TURN ON SAVE FLAG
         AI,R1    -2                ACCESS CONTROL BYTE
         LI,R14   X'C1'             CODE FOR FIRST CLUSTER IN CONDITION
         STB,R14  0,R1
         B        COMX              OUTPUT CLUSTER
VARBYFR  CI,STOP  4                 IS IT VARYING
         BNE      PFBY              NO- CHECK IF BY
         LB,R14   JTJF,UP2          IS THIS THE FIRST
         CI,R14   1                 OR ONLY VARYING
         BE       PFOUT             YES- OUTPUT IT
         MTB,-1   JTJF,UP2          NO- DECREMENT JTJF
         STB,R15  PSFLAG,UP3        TURN OFF SAVE FLAG
         B        PFSAVE            SAVE VARYING
PFELEM   LB,R13   PSFLAG,UP3        IS SAVE FLAG ON
         BNEZ     PFSAVE            YES- SAVE CLUSTER
         B        PFOUT
PFBY     CI,STOP  X'10'             IS IT 'BY'
         BNE      PFELEM            NO- CHECK IF IT MUST BE SAVED
         LB,R14   JTJF,UP2          IS JTJF COUNT 1
         CI,R14   1                 FIRST OR ONLY VARYING
         BNE      PFSAVE            NO- SAVE CLUSTER
*        AT THIS POINT ALL CLUSTERS WHICH HAVE BEEN SAVED MUST BE
*        PUT OUT AHEAD OF V1,F1,B1
SAVOUT   LI,R13   X'F0'             TELL OUTPUT ROUTINE
         STB,R13  WCHBUF,UP3        TO USE SAVE BUFFER
         STB,R15  PSFLAG,UP3        TURN OFF SAVE FLAG
         LI,R4    BA(SAVBUF)        POINT TO BUFFER
         STW,R4   SAVPTR            AND INITIALIZE POINTER ADDRESS
         BAL,R11  OCC               OUTPUT SAVE AREA
         B        COMX              OUTPUT CURRENT AND EXIT
PFSAVE   RES      0
         LB,R13   0,R2              CLUSTER LENGTH INTO R13
         AW,R13   R13               BYTE ADDRESSING
         LW,R3    SAVPTR            DESTINATION ADDRESS
         AW,R3    R13
         CI,R3    BA(ENDSV)         WILL CLUSTER FIT
         BG       PFDIAG            NO
         LW,R3    SAVPTR
         STB,R13  R3                LENGTH INTO COUNT FIELD
         MBS,R2   0                 MOVE CLUSTER
         LI,R13   0                 ZERO OUT
         STB,R13  0,R3              NEXT CHARACTER OF SAVE AREA
         STW,R3   SAVPTR            NEXT LOCATION INTO POINTER ADDRESS
         B        CLIP              GET NEXT CLUSTER
PFDIAG   LI,R1    X'74'             CODE FOR LIMITATION EXCEEDED
         BAL,R11  DIAG              PUT OUT DIAGNOSTIC
         B        CLIP              GET NEXT CLUSTER
         PAGE
*        OUTPUT CLUSTER(S) ROUTINE
OCC      STW,R11  OCCR              SAVE RETURN
         LB,R13   WCHBUF,UP3        IS IT A SAVE AREA
         BNEZ     OOPS              YES
         LB,R13   CLUNO,UP1         IS IT FIRST CLUSTER
         BNEZ     FRSTCL            OF STATEMENT
         LI,R15   0
CLOP     BAL,R11  WRCRF             I/O CALL - WRITE ON CRF
         CI,R15   0
         BE       *OCCR
         AI,R4    3
         LI,R15   X'80'             RESET NEW STATEMENT OPTION
         STB,R15  0,R4
         B        *OCCR             RETURN
OOPS     BAL,R11  WRCRF             I/O CALL - OUTPUT SAVED CLUSTER
         CI,R13   X'F0'             MORE THAN ONE
         BNE      *OCCR             NO- RETURN
NXTOUT   LB,R13   0,R4              ADD CLUSTER LENGTH
         AW,R13   R13                   IN BYTES
         AW,R4    R13               TO OUTPUT REGISTER
         LB,R13   0,R4              ANOTHER CLUSTER WAITING
         BEZ      *OCCR             NO- RETURN
OUTCH    BAL,R11  WRCRF             OUTPUT ON CRF
         B        NXTOUT            CHECK FOR MORE
FRSTCL   LI,R15   X'80'             FLAG NEW
         STB,R15  NEWS,UP2              STATEMENT COMING
         LW,R1    R4
         AI,R1    1
         LW,R13   SAVER             ANYTHING SAVED FOR AHEAD OF FIRST
         BEZ      NOSAVE            NO CLUSTER SAVED
         STB,CBYT 0,R1              REPLACE WITHOUT FIRST CLUSTER BIT
         LH,R14   SAVER,UP1         ONLY ON SIZE ERROR SAVED
         BEZ      SZEROUT           YES- PUT OUT THIS CL. AND ON SIZE
FRSTOUT  BAL,R11  WRCRF             WRITE OUT ORIGINAL FIRST CLUSTER
         LH,R14   SAVER,UP1         LOAD SAVED CLUSTER COUNT
         LI,R4    BA(SAVBUF)        INITIALIZE OUTPUT REGISTER TO SAVE
ONELEFT  CI,R14   1                 ONE SAVED CLUSTER REMAINING
         BE       CHKSZ             YES- SEE IF ON SIZE ERROR WAITING
         LB,R10   0,R4              SAVE CLUSTER LENGTH
         AW,R10   R10                   IN BYTES
         BAL,R11  WRCRF             WRITE OUT THIS SAVED CLUSTER
         AW,R4    R10               POINT TO NEXT SAVED CLUSTER
         MTW,-1   R14               DECREMENT SAVED CLUSTER COUNT
         B        ONELEFT           CHECK IF MORE
CHKSZ    LB,R13   SAVER             PICK UP ON SIZE ERROR FLAG
         BNEZ     SZEROUT           GO PUT OUT CURRENT AND ON SIZE ERROR
         LI,R13   BA(SAVBUF)
         STW,R13  SAVPTR            INITIALIALIZE POINTER ADDRESS
NEWFSTCL LW,R1    R4                PICK UP
         AI,R1    1                     CONTROL BYTE
         LB,R13   0,R1              TURN ON
         OR,R13   R15                   FIRST CLUSTER BIT
         STB,R13  0,R1              IN THIS CLUSTER
         BAL,R11  STRCLEAR          CLEAR ALL FLAGS                     COBOL31
NOSAVE   LW,R15   DSPNTR
         BEZ      CLOP
         STW,R13  DSPNTR            RESET DSPNTR
         AI,R1    2
         LB,R13   0,R1
         OR,R13   R15
         STB,R13  0,R1              SET DISPLAY UPON PRINTER FLAG
         B        CLOP              OUTPUT AND RETURN
SZEROUT  BAL,R11  WRCRF             WRITE OUT CURRENT CLUSTER
         LI,R4    BA(ONSZR)         WRITE OUT
         B        NEWFSTCL-2        ON SIZE ERROR AND RETURN
STRCLEAR EQU      %                                                     COBOL31
         LI,R13   0                                                     COBOL31
         STW,R13  SAVER                                                 COBOL31
         STW,R13  DDELM                                                 COBOL31
         STW,R13  PNTR1                                                 COBOL31
         STW,R13  PNTR2                                                 COBOL31
         STW,R13  INTO:FLG                                              COBOL31
         B        *R11                                                  COBOL31
DSPNTR   DATA     0                 UPON PRINTER FLAG
         PAGE
*        ROUTINE TO SET HIGH ORDER BIT OF STATEMENT OPTIONS FIELD
*        IF INPUT CLUSTER IS LAST VALID OPERAND OF STATEMENT
*        UPON EXITING  R1 CONTAINS ADDRESS OF STATEMENT OPTIONS FIELD
*                      R14 CONTAINS NEW STATEMENT OPTIONS
*                      R15 CONTAINS ZERO FOR USE BY DANAM ROUTINE
LOPRAND  LW,R1    R2                CLUSTER ADDRESS INTO R1
         AI,R1    3
         LB,R14   0,R1              LOAD IT
         LI,R15   0
         CI,CBYT  X'5B'             IS IT IN 'GO TO'
         BNE      LOPON             NO - SET THE BIT
         CI,RTYP  4                 IS IT A PROCEDURE NAME
         BNE      *R11              NO - RETURN WITH R1,R14,R15 SET
LOPON    LB,R13   NEWS,UP2          TURN ON LAST OPERAND BIT
         OR,R14   R13               IF NEWS IS ON
         LB,R13   SUBJECT,UP1       POSSIBLE CONDITIONAL SUBJECT FLAG
         BEZ      NOTSUBJ           NOT A SUBJECT
         LI,R13   X'10'             TURN ON BIT
         OR,R14   R13
         LB,R13   CLUNO,UP1         IS THIS FIRST CLUSTER
         BEZ      %+2               NO- LEAVE FLAG ON
         STB,R15  SUBJECT,UP1       TURN OFF POSSIBLE SUBJECT FLAG
*        SIDR 1597 - PERFORM VARYING UNTIL CAUSES HIGH-ORDER BIT TO     COBOL31
*                    STAY ON IN NUMBER CLUSTERS                         COBOL31
         CI,CBYT  X'61'              TEST IF PEROFRM                    COBOL31
         BNE      NOTSUBJ            NO                                 COBOL31
         CI,STOP  2                 SEE IF RRACHED 'UNTIL' YET          COBOL31
         BNE      NOTSUBJ           NO-LEAVE SUBJECT FLAG ON            COBOL31
         STB,R15  SUBJECT,UP1        TURN OFF SUBJECT FLAG              COBOL31
NOTSUBJ  STB,R14  0,R1              STORE IN CLUSTER
         STB,R15  NEWS,UP2          ZERO OUT LAST OPERAND FLAG
         B        *R11              RETURN
         PAGE
*
*        G E T D E F          S U B R O U T I N E S
*ROUTINE *PURPOSE *CALLS   *INPUT   *INPUT   *OUTPUT  *OUTPUT  *OUTPUT
*        *        *ROUTINE *IN REG. *IN REG. *IN REG. *IN REG. *
*-----------------------------------------------------------------------
*NXTRNUM |GET NEXT| GETIX  | R2     | R1     | R12    |  R3    |
*        |R<NO. IN|        | EPF    | HALF WD|        |        |
*        |CLUSTER.|        | CLUSTER|ADDRESS |ABSOLUTE| DINDEX |
*        |TURN OFF|        |        |CURRENT |REFER.  | ENTRY  |
*        |HIGH BIT|        |        |REF. NO.|NUMBER  |        |
*        |AND TURN|        |        |        |        |        |
*        |ON QORN |        |        |        |        |        |
*-----------------------------------------------------------------------
*GETIX   |OBTAIN  |        | R12    |        | R3     |        |
*        |DINDEX  |        |REF. NO.|        |        |        |
*        |ENTRY   |        |(DISPL< |        | DINDEX |        |
*        |FOR REF<|        |FROM    |        | ENTRY  |        |
*        |NUMBER  |        |BASE OF |        |        |        |
*        |        |        |DINDEX) |        |        |        |
*-----------------------------------------------------------------------
*CHAINLK |PICK UP |DICTATE |R3      | R4     |R3      |R4      |RETURN
*        |SYNONYM |        | DINDEX | (SEE   |SYNONYM |LOCATION| + 1
*        |LINKAGE |        | ENTRY  |DICTATE)|LINKAGE |FIELD C |IF LINK.
*        |OF DICT.|        |        |        |        |DICTION.|FILLED
*        |ITEM AND|        |        |        |        |        |
*        |TEST IF |        |        |        |        |        |
*        |FILLED  |        |        |        |        |        |
*-----------------------------------------------------------------------
*DICTATE |LOCATE  |        | R3     |        | R4     |        |
*        |DICTION.|        |        |        |WORD    |        |
*        |ITEM FOR|        |DINDEX  |        |ADDRESS |        |
*        |DINDEX  |        |ENTRY   |        |OF DICT.|        |
*        |ENTRY   |        |        |        | ENTRY  |        |
*-----------------------------------------------------------------------
         PAGE
*        ROUTINE FOR SATISFYING REFERENCE CLUSTERS
*        REPLACING REFERENCE NUMBERS WITH INFORMATION
*        IN DICTIONARY FROM APPROPRIATE DEFINITION
GETDEF   RES       0
         LCI      4                 SAVE
         STM,R3   SAVEREG           REGISTERS 3-6
         STW,R11  NESTRET1          SAVE RETURN
         LI,R12   0                 FOR LOWER LIMIT
         STB,R12  NUR               TURN OFF NON UNIQUE FLAG
         STB,R12   QFLG
         LW,R13   PDBO              HIGHEST DATA DICT. SEGMENT
         CI,RTYP  2                 DATA OR PROCEDURE
         BG       PROPR             PROCEDURE REFERENCE OR DEFINITION
         STD,R12  SB1               ZERO SB1
         B        GETD              PROCESS DATA REFERENCE
PROPR    STW,R13  SB1               LOWEST PROCEDURE DICTIONARY SEGMENT
         LW,R13   HSN               HIGHEST DICTIONARY SEGMENT
         STW,R13  SB2               INTO SB2
GETP     LW,R1    R2                CLUSTER ADDRESS
         SLS,R1   -1                HALF WORD ADDRESS
GETNP    BAL,R11  NXTRNUM           TEST FOR QUAL. AND GET DINDEX ENTRY
         CI,R3    0                 DINDEX ENTRY ZERO
         BE       POSSPRM           YES-UNDEFINED- CHECK IF EXTERNAL
*   FIXES TRAP WHEN ALL OF THE PROCEDURE DIVISION DICTIONARIES          COBOL31
*     DONT  FIT IN CORE.                                                COBOL31
RESTR   RES       0                                                     COBOL31
         LW,R14   R3                                                    COBOL31
         AND,R14  SEGN             IS SEGMENT IN CORE                   COBOL31
         BEZ      %+3                  YES                              COBOL31
         CW,R14   LSN                                                   COBOL31
         BLE      TOMAIN              NO                                COBOL31
         CLM,R3   SB1            IS IT IN LIMITS                        COBOL31
         BCS,9    CHKCHAIN               NO                             COBOL31
         LB,R12   QORN              IN RANGE- ANY MORE REFERENCE NOS.
         BEZ      SIMNAM            NO- PROCESS SIMPLE NAME
         BAL,R11  CSYN              CHECK FOR DUPLICATE DEFINITION
         AND,R3   SEGN              SEGMENT NUMBER
         STD,R3   SB1                   AND ZERO INTO SB1
         LW,R13   DISPL                 AND  ALL  BITS
         STS,R13  SB2                             INTO SB2
         AI,R1    1                 PROCESS NEXT REFERENCE NUMBER
         B        GETNP             MAKE SURE IT IS WITHIN THIS SECTION
CHKCHAIN BAL,R11  CHAINLK           CHECK SYNONYM CHAIN
         B        POSSPRM           END OF CHAIN-CHECK IF PARAMETER NAME
         B        RESTR             PROCESS NEXT ENTRY IN CHAIN
SIMNAM   BAL,R11  CHAINLK           CHECK SYNONYM CHAIN
         B        PCONST            END OF CHAIN. BUILD NEW CLUSTER
         CLM,R3   SB1               IS IT IN RANGE OF SB1 AND SB2
         BCS,9    PCONST            OUT OF RANGE
         LB,R13   QFLG              WAS REFERENCE QUALIFIED
         BEZ      SECQ              NO- QUALIFY IT WITH PRESENT SECTION
         LI,R13   0                 TURN OFF
         STB,R13  QFLG              FLAG
         STB,R7   NUR               NON UNIQUE INDICATOR
PCONST   LW,R3    R2                PICK UP
         AI,R3    2                    OPERAND
         LB,R13   0,R3                 OPTIONS
         OR,R13   L(X'10')          CHANGE TO TYPE '9'
         STB,R13  0,R3              PUT IN CLUSTER
         LB,R13   NUR               CHANGE NUR
         BEZ      %+2                  TO 2 IF ON
         MTB,1    NUR
         LW,R13   RSAVE             CHECK IF REF,DEF, OR PARAMETER
         CI,R13   4                 REF OR PARAMETER
         BAZ      DEFCONST          NO- BUILD DEFINITION CLUSTER
         CI,R13   2                 PARAMETER NAME
         BAZ      REFCONST          NO- BUILD REFERENCE CLUSTER
         MTB,-2   0,R3              CHANGE TO TYPE '94'
         B        REFCONST             AND BUILD REFERENCE CLUSTER
         PAGE
*        DEFINITION - BUILD PROCEDURE DEFINITION CLUSTER
DEFCONST RES      0
         LI,R3    BA(CRFBUILD)      SET UP
         OR,R3    COUNT3            DESTINATION REGISTER
         MBS,R2   0                 MOVE 3 BYTES FROM EPF CLUSTER
         LW,R2    R4                SET R2
         AI,R2    -4                TO BEGINNING OF DICTIONARY ITEM
         LB,R13   0,R2              TYPE
         STB,R13  0,R3              INTO FIELD G OF CRF CLUSTER
         AI,R3    1                 INCREMENT DESTINATION REGISTER
         AI,R2    8                 POINT TO PROCEDURE REFERENCES
         LB,R12   0,R2              SAVE PROCEDURE REFERENCES BYTE
         OR,R3    COUNT8            MOVE
         MBS,R2   0                     8 BYTES FROM DICTIONARY
         SLS,R3   -1                HA
         LH,R13   INLBR             INTERNAL LABEL
         STH,R13  0,R3                  RANGE
         AI,R3    1                 INCREMENT BY HALF WORD
         AW,R3    R3                BYTE ADDRESS
         CI,R12   X'7F'             IS HIGH ORDER BIT OF PROC. REF  ON
         BG       DEXEX
DEFEX    BAL,R11  PADDLE            APPEND FILLER
         LI,R3    BA(CRFBUILD)+3    PICK UP
         LB,R13   0,R3                  TYPE CODE
         CI,R13   X'95'             IS IT DECLARATIVE SECTION
         BNE      TOMAIN            NO-EXIT
         LI,R5    3                 IS USE BEFORE REPORTING
         LB,R13   USER,R5               FLAG ON
         BEZ      TOMAIN            NO-RETURN
         AI,R3    3                 TO DEF, ENTRY NO.
         SLS,R3   -1                HA
         LH,R13   0,R3              DEF NO.
         SLS,R13  8                 TO BITS 17-24
         STH,R13  *USEPOINT,UP1         TO UBR TABLE ENTRY
         AI,R3    2                 TO EXIT
         LH,R13   0,R3                  NUMBER
         AWM,R13  *USEPOINT         PUT IN TABLE
         MTW,1    USEPOINT          INCREMENT TABLE INDEX
         MTB,-1   USER,R5           TURN OFF FLAG
         LW,R6    USEPOINT                                              COBOL31
         CI,R6    USEND             HAVE WE OVERFLOXED TABLE            COBOL31
         BLE      TOMAIN            NO                                  COBOL31
         LI,R1    279                                                   COBOL31
         BAL,R11  DIAG              FATAL DIAG MORE THAN 64 USE STATE   COBOL31
DEXEX    LB,R13   0,R2              EXTERNAL REFERENCE
         AI,R13   1                 LNGTH OF NAME PLUS 1
         STB,R13  R3                    INTO COUNT FIELD DEST. REGISTER
         MBS,R2   0                 MOVE LENGTH BYTE AND NAME
         B        DEFEX             EXIT
SECQ     LH,R1    NUMBERS,UP1       LOAD CURRENT SECTION NUMBER
         OR,R1    QBIT              TURN ON QUALIFICATION BIT
         LW,R4    CPTR              PUT INTO CLIST
         STH,R1   0,R4              BUMP CLIST POINTER
         AWM,UP1  CPTR              BUILD NEW CLUSTER
         BAL,R11  BUILD00           RESOLVE WITH SECTION AS QUALIFIER
         B        GETP
POSSPRM  LW,RTYP  SAVEREG
         CI,RTYP  6                 IS IT A PARAMETER NAME
         BNE      %+5               NO- UNDEFINED
         LI,R12   0                 CHANGE
         LW,R13   PDBO                SEARCH
         STD,R12  SB1                  LIMITS
         B        GETD              TO DDD
         LW,R13   LSN               IF THIS IS NOT THE LAST PASS
         BNEZ     TOMAIN            RETURN TO CALLING PROGRAM
EXPRM    LB,R13   1,R2              REF. NO.
         CI,R13   X'7F'             IS IT QUALIFIED
         BG       PUNDIT            YES- ERROR - RETURN UNRESOLVED
         LI,R13   X'A4'             EXTERNAL REFERENCE
         LW,R4    R2                PICK UP
         AI,R4    2                     OPERAND OPTIONS
         STB,R13  0,R4              CHANGE TO TYPE A
         LI,R13   X'0704'           CROSS REFERENCE CODE FOR EXTERNAL
PXRFU    BAL,R11  XRFU              PUT OUT ON XRF IF REQUESTED
         LI,R4    2
         BAL,R11  CCBUILD           REBUILD CLUSTER WITHOUT REF. NUMBER
         B        TOMAIN            RETURN TO CALLING PROGRAM
PUNDIT   LI,R13   X'0703'           CROSS REFERENCE CODE FOR ERROR
         B        PXRFU             OUTPUT TO XRF AND RETURN
TOMAIN   LCI      4                 RESTORE
         LM,R3    SAVEREG
         MTW,0    R2SAV             SEE IF CORRES CHANGED R2
         BEZ      TOMAIN1           NO
         LW,R2    R2SAV             YES
         LI,R1    0
         STW,R1   R2SAV             RESET R2SAV
TOMAIN1  RES      0
         LB,R13   NUR               IS NON UNIQUE FLAG ON
         BEZ      *NESTRET1         NO- RETURN
         LB,R1    NUR               FLAG- 1 IF DATA,2 IF PROCEDURE REF.
         AI,R1    X'57'             88-DATA 89-PROCEDURE REF. DIAG.
         BAL,R11  DIAG              PUT OUT DIAGNOSTIC
         B        *NESTRET1
         PAGE
*        ROUTINE TO CONSTRUCT CRF CLUSTER REPLACING
*        PROCEDURE REFERENCE NUMBER WITH DICTIONARY INFORMATION
*        R2 CONTAINS BYTE ADDRESS OF EPF CLUSTER
*        R4 CONTAINS BYTE ADDRESS OF FIELD C OF DICTIONARY DEFINITION
*        R2 WILL CONTAIN BYTE ADDRESS OF NEW CLUSTER
*        R3 CONTAINS SYNONYM LINKAGE FIELD
REFCONST RES      0
         SLS,R4   -2                WORD ADDRESS OF LINE NO. INFO
         LW,R5    0,R4              LINE NUMBER AND COPY LINE NUMBER
         STW,R5   LINENTRY             INTO CROSS REFERENCE CLUSTER
         SLS,R4   2                 REVERT TO BYTE ADDRESSING
         LI,R5    BA(CRFBUILD)+2    SET UP
         LI,R3    BA(CRFBUILD)      RECEIVING REGISTERS
         OR,R3    COUNT4            MOVE FIRST FOUR BYTES
         MBS,R2   0                 FROM CURRENT CLUSTER
         AI,R4    -4                TO FIELD A OF PDD
         LB,R13   0,R4              MOVE
         STB,R13  0,R5              TYPE
         AI,R4    8                 POINT TO FIELD E OF PDD
         AI,R5    2                 POINT TO FIELD I OF NEW CLUSTER
         OR,R5    COUNT4            MOVE 4 BYTES
         MBS,R4   0                 TO NEW CLUSTER
         AI,R4    2                 POINT TO EXIT NUMBER IN PDD
         OR,R5    COUNT2            MOVE EXIT NUMBER
         MBS,R4   0                 TO NEW CLUSTER
         LW,R3    R5                PAD
CLUPAD   BAL,R11  PADDLE
         LI,R13   X'0702'           CROSS REFERENCE CODE FOR MATCH
         BAL,R11  XRFD              WRITE OUT CROSS REFERENCE
         B        TOMAIN            RETURN TO CALLING PROGRAM
PADDLE   LI,R13   X'FF'             APPEND
         STB,R13  0,R3                  FILLER BYTE
         AI,R3    2                 DETERMINE
         LI,R2    BA(CRFBUILD)          CLUSTER
         SW,R3    R2                    LENGTH
         SLS,R3   -1                DIVIDE BY 2
         STB,R3   0,R2              PUT LENGTH INTO FIRST BYTE
         B        *R11
NXTRNUM  STW,R11  NESTRET2
         LH,R12   1,R1              REFERENCE NUMBER - R1
         BLZ      QREFN             HIGH ORDER BIT ON - QUALIFIER
         LI,R13   0                 SIMPLE NAME -
         STB,R13  QORN                  ZERO OUT FLAG
         STH,R12  XRFBUILD,UP1      PUT REFERENCE NO. INTO XRF CLUSTER
         STH,R12  REF#              SAVE FOR DEBUG                      COBOL31
PINR     BAL,R11  GETIX             GET CORRESPONDING DINDEX ENTRY
         B        *NESTRET2         RETURN
QREFN    AND,R12  LOFIFTN           MASK OUT SIGN BITS AND QUALIF. BIT
         STB,R7   QORN              TURN ON QUALIFIER INDICATOR
         STB,R7   QFLG              TURN ON QUALIFICATION FLAG
         B        PINR              GET DINDEX ENTRY IN R3 AND RETURN
         PAGE
*        ROUTINE TO CHECK FOR DUPLICATE DEFINITIONS
CSYN     RES      0
         STW,R11  NESTRET3
         STW,R3   SAVEREG+4         SAVE CURRENT DINDEX ENTRY
         BAL,R11  CHAINLK           GET SYN. LINKAGE AND TEST IF FILLED
         B        SYNEX             END OF CHAIN
         CLM,R3   SB1               IS LINKAGE ALSO WITHIN RANGE
         BCS,9    SYNEX             NO- RETURN
         STB,UP1  NUR               TURN ON NON UNIQUE FLAG
SYNEX    LW,R3    SAVEREG+4         RESTORE CURRENT ENTRY
         B        *NESTRET3
         PAGE
GETD     LW,R1    R2                CLUSTER ADDRESS - R1
         SLS,R1   -1                HALF WORD ADDRESS
GETND    BAL,R11  NXTRNUM           SELECT NEXT REFERENCE NUMBER
         CI,R3    0                 IS DINDEX EMPTY
          BE        DXRFU                                               COBOL31
         STD,R3   R14               SAVE IN BOTH R14 AND R15
         AND,R14  SEGN              MASK THROUGH SEGMENT NUMBER
         CW,R14   LSN               IS SEGMENT IN MEMORY
         BG       DMAIN
         CI,R14   0                 SEGMENT NUMBER THIS ITEM 0
          BNE       DXRFU                                               COBOL31
         LW,R13   SB1               SEGMENT 0 REFERENCED
          BNEZ      DXRFU                                               COBOL31
GETFD    LB,R13   QORN              MORE REFERENCE NUMBERS?
         BEZ      FILEREF           NO- FILE REFERENCE- BUILD CLUSTER
         LW,R13   RSAVE             IS THIS A DATA NAME
         CI,R13   X'FD'                 OR SUBSCRIPT DATA NAME
          BANZ      DXRFU                                               COBOL31
         AND,R15  DISPL
         LW,R4    PDBZ+3            DB AREA ARIGIN
         AW,R4    R15                   PROPER ENTRY IN DDB
         SLS,R4   -1                HALF WORD ADDRESS
         LH,R12   1,R4              BEGINNING OF DICTIONARY RANGE
         AND,R12  LOW10             MASK THRU BITS 6-15
         SLS,R12  14                SEGNO POSITION
* THE FOLLOWING FOUR LINES  FIXES TRAP WHEN PROCESSING A REFERENCE      COBOL31
* QUALIFIED BY A 'FD' NAME AND ALL OF THE 01'S OF THAT FD DO NOT        COBOL31
* FIT IN CORE.   GG                                                     COBOL31
         CW,R12   LSN                                                   COBOL31
         BG       %+3                                                   COBOL31
         LW,R12   LSN                                                   COBOL31
         OR,R12   DISPL                                                 COBOL31
         AI,R4    1
         LH,R13   1,R4              END OF DICTIONARY RANGE
         AND,R13  LOW10             MASK THRU BITS 6-15
         SLS,R13  14                SEGNO POSITION
         OR,R13   DISPL             ALL BITS
         STD,R12  SB1               LIMITS INTO SB1 AND SB2
         AI,R1    1                 PROCESS NEXT
         B        GETND                 REFERENCE NUMBER
DXRFU    RES      0                                                     COBOL31
         AND,CBYT L(X'7F')                                              COBOL31
         CI,CBYT  X'74'                                                 COBOL31
         BL       DXRFU3            NOT CORRESPONDING                   COBOL31
         CI,CBYT  X'77'                                                 COBOL31
         BLE      TOMAIN            CORRESPONDING                       COBOL31
DXRFU3   RES      0                                                     COBOL31
         LW,R13   LSN               IS IT THE LAST PASS                 COBOL31
         BEZ      DXRFU1            YES                                 COBOL31
DXRFU30  RES      0                                                     COBOL31
         CI,R2    BA(NEWCL)                                             COBOL31
         BNE      DXRFU0            NOT IN NEWCL                        COBOL31
         AI,R2    -2                MAKE ROOM FOR                       COBOL31
         LH,R6    NEWCL                                                 COBOL31
         STW,R6   ONEW                SUB / REF#                        COBOL31
         LW,R6    NEWCL                                                 COBOL31
         SLS,R6   16                                                    COBOL31
         STW,R6   NEWCL                                                 COBOL31
         B        DXRFU2                                                COBOL31
DXRFU0   RES      0                                                     COBOL31
         LW,R4    R2                YES                                 COBOL31
         SLS,R4   -1                MOVE REF#                           COBOL31
         LH,R5     REF#                                                 COBOL31
         LI,R6    0                TO 2ND HALF WORD                     COBOL31
         STH,R6   1,R4                                                  COBOL31
         AI,R4    1                                                     COBOL31
         STH,R5   1,R4             OF 2ND WORD                          COBOL31
DXRFU2   MTB,1    0,R2              ADJUST LENGTH COUNT                 COBOL31
         B        TOMAIN            RETURN                              COBOL31
DXRFU1   RES      0                                                     COBOL31
         LW,RTYP  SAVEREG           PICK UP REFERENCE TYPE
         CI,RTYP  6                 IS IT A PARAMETER NAME
         BE       EXPRM             YES
         LI,R13   X'0703'           CROSS REFERENCE CODE FOR ERROR
         BAL,R11  XRFU              OUTPUT ON XRF IF REQUESTED
         B        DXRFU30           PUT IN REF # AND GET OUT            COBOL31
FILEREF  RES      0
         LI,R3    BA(CRFBUILD)      DESTINATION REGISTER
         OR,R3    COUNT4            MOVE FOUR BYTES
         MBS,R2   0                     FROM EPF CLUSTER
         MTW,0    PDBDBG                                                COBOL31
         BEZ      FILEREF2          DEBUG FLAG OFF                      COBOL31
         SLS,R3   -1                H.A. FOR REF#                       COBOL31
         LH,R4    REF#                                                  COBOL31
         STH,R4   0,R3              PUT IN CLUSTER                      COBOL31
         SLS,R3   1                 B.A.                                COBOL31
         AI,R3    2                 ADD 2 FOR REF#                      COBOL31
FILEREF2 RES      0                                                     COBOL31
         LW,R4    PDBZ+3            DB ORIGIN
         AW,R4    R15               ADD DISPLACEMENT
         LB,R13   0,R4              D.B. I.D.
         CI,R13   5                 IS IT AN RDB
         BE       RDBNO             YES
         LB,R13   10,R4             DDB POINTER
         AI,R4    X'29'             ACCESS NAME
DBLINE   LB,R14   0,R4                 LENGTH
         AW,R4    R14               ADD TO POINTER
DBL1     SLS,R4   -2                   NUMBER
         AI,R4    1                 STORE IT
         LW,R15   0,R4              DB LINE NUMBER
         STW,R15  LINENTRY          INTO XRF CLUSTER
         STB,R13  0,R3                  INTO CRF CLUSTER
         MTW,0    PDBDBG                                                COBOL31
         BEZ      DBL2              NORMAL CLUSTER                      COBOL31
         AI,R3    -4                BACK UP TO OPERAND OPTIONS          COBOL31
         LI,R13   X'93'             CODE FOR FILE REF                   COBOL31
         STB,R13  0,R3                 INTO OPERAND OPTIONS             COBOL31
         LI,R2    BA(CRFBUILD)      R2 TO NEW CLUSTER                   COBOL31
         LI,R13   4                 LENGTH OF 4 (HALF WORDS)            COBOL31
         STB,R13  0,R2              INTO NEW CLUSTER                    COBOL31
         B        REFEXIT                                               COBOL31
DBL2     RES      0                                                     COBOL31
         AI,R3    -2                BACK UP TO OPERAND OPTIONS
         LI,R13   X'93'             CODE FOR FILE REF
         STB,R13  0,R3                  INTO OPERAND OPTIONS
         LI,R2    BA(CRFBUILD)      R2 TO NEW CLUSTER
         LI,R13   3                 LENGTH OF 3
         STB,R13  0,R2              INTO NEW CLUSTER
REFEXIT  LI,R13   X'0702'           CROSS REFERENCE CODE FOR MATCH
         BAL,R11  XRFD              WRITE OUT CROSS REFERENCE ENTRY
         CI,CBYT  X'6C'             IS IT IN USE STATEMENT
         BNE      CORRES            NO- CHECK IF IN 'CORRESPONDING'
         LW,R1    R2                PICK
         AI,R1    6                     UP
         LB,R13   0,R1                  TYPE CODE
         SLS,R13  -4                SHIFT TO LOW ORDER
         CI,R13   4                 IS IT REPORT TYPE
         BNE      TOMAIN            NO- RETURN TO CALLING PROGRAM
*        CONSTRUCT USE BEFORE REPORTING TABLE ENTRY
         LW,R4    USEPOINT          PICK UP NEXT AVAILABLE >LOT IN TABLE
         AI,R1    6      PICK UP
         LB,R13   0,R1      FIELD N (REPT DB NUMBER)
         STB,R13  *USEPOINT         BYTE 1 OF TABLE ENTRY
         AI,R1    5      PICK UP
         LB,R13   0,R1      FIELD R (REPT GROUP REF NUMBER)
         STB,R13  *USEPOINT,UP1     BYTE 2 OF TABLE ENTRY
         LI,UP3   3
         STB,UP1  USER,UP3          TURN ON FLAG
         B        TOMAIN
RDBNO    LB,R13   3,R4              RDB POINTER
         AI,R4    13                ACCESS NAME LENGTH                  COBOL31
         B        DBLINE
         PAGE
DBOLT    RES      0                 SEG OUT OF RANGE
         LW,R14   R3                IS THIS
         AND,R14  SEGN                 SEGMENT IN
         CW,R14   LSN                  MEMORY
         BLE      DXRFU             NO- THIS PASS CANNOT RESOLVE
         BAL,R11  CHAINLK           CHECK IF SYNONYM LINKAGE FILLED
         B        DXRFU             END OF CHAIN
         STD,R3   R14               R3 TO R14 &R15
         AND,R14   SEGN               DOES LINKAGE POINT
         CI,R14   0                     TO SEGMENT ZERO
*    THE FOLLOWING FOUR LINES OF CODE FIX A TRAP WHEN A PARAGRAPH       COBOL31
*    NAME AND A DATA NAME ARE THE SAME AND BOTH ARE NOT IN CORE         COBOL31
*   AT THE SAME TIME.                                                   COBOL31
         BE       GETFD                                                 COBOL31
         CW,R14   LSN                                                   COBOL31
         BG        DMAIN                                                COBOL31
         B         DXRFU                                                COBOL31
DQUAL    STW,R3   SB1               LOCATION OF CURRENT ENTRY
         BAL,R11  DICTATE           LOCATE DICTIONARY ENTRY
         SLS,R4   2                 BYTE ADDRESS
         AI,R4    9                 INCREMENT TO END OF RANGE POINTER
         LI,R3    0                 CLEAR RECEIVING FIELD
         LW,R5    RBYST             MOVE END OF RANGE
         MBS,R4   0                     TO R3
         LW,R4    SEGN              PICK UP SEGENT NUMBER
         AND,R4   SB1                  FROM LOWER LIMIT
         OR,R3    R4                PUT IN UPPER LIMIT
         STW,R3   SB2               STORE IN UPPER SEARCH LIMIT
         AI,R1    1                 PROCESS NEXT
         B        GETND                 REFERENCE NUMBER
DMAIN    RES      0
         CLM,R3   SB1               IN RANGE OF SB1 AND SB2
         BCS,9    DBOLT             OUT OF RANGE
         BAL,R11  CSYN              CHECK FOR DUPLOCATE DEFINITION
         LB,R13   NUR               IS NON UNIQUE INDICATOR ON
         BEZ      UNIQUED           NO
         MTB,-1   NUR               TURN IFF NUR FLAG
         STW,R1   SAVEREG+4         SAVE R1
         LI,R1    X'58'             CODE FOR NON UNIQUE DATA REF
         BAL,R11  DIAG              PUT OUT DIAGNOSTIC
         LW,R1    SAVEREG+4         RESTORE R1
UNIQUED  LB,R13   QORN              ANY MORE REFERENCE NUMBERS
         BNEZ     DQUAL             YES- CHANGE SEARCH LIMITS
         PAGE
DATAREF  RES      0                 BUILD DATA REFERENCE CLUSTER
         BAL,R11  DICTATE           LOCATE DICTIONARY ITEM
         STW,R4   DPONTR            DDD POINTER
         LI,R3    BA(CRFBUILD)      NEW CLUSTER ADDRESS
         MTW,0    PDBDBG            IS DEBUG SWITCH ON                  COBOL31
         BEZ      MOV4                                                  COBOL31
         OR,R3    COUNT6            YES--SAVE REFERENCE NUMBER          COBOL31
         B        %+2                                                   COBOL31
MOV4     RES      0                                                     COBOL31
         OR,R3    COUNT4            MOVE 4 BYTES
         LI,OTYP  X'90'             NEW OPERAND TYPE
         LW,R6    R2                PICK UP
         AI,R6    2                     OPERAND
         LW,R13   2,R4              LEVEL NUMBER IN BYTE 0
         LI,R14   X'58'             CHECK IF THIS
         CB,R14   R13                   IS A CONDITION NAME
         BNE      %+3               NO
         LI,R13   1                 CHANGE OPERAND OPTIONS
         B        %+2                    TO '9'
         LB,R13   0,R6                  OPTIONS
         OR,R13   OTYP              CHANGE TO TYPE 9
         CI,R13   X'96'             IS IT A PARAMETER NAME
         BNE      %+2               NO
         AI,R13   -6                CHANGE TO DATA NAME
         STB,R13  0,R6              IN NEW CLUSTER
         SLS,OTYP -4                SAVE OTYP FOR CORRESPONDING ROUT.
         MBS,R2   0                 FROM EFP CLUSTER
         LW,R6    R4                SAVE WORD ADDRESS DDD ITEM (CORRES)
         SLS,R4   2                 BYTE ADDRESS OF DDD ITEM
         LB,R15   0,R4              SAVE DDD ITEM LENGTH
         SLS,R15  2                    IN BYTES
         AI,R4    14                INCREMENT TO FIELD H
         AI,R3    2                 ALLOW FOR FIELD E
         LW,R2    R4                THIS ADDRESS TO SOURCE REGISTER
         AI,R15   -14               LENGTH OF REMAINDER
         STB,R15  R3                    INTO COUNT FIELD DEST. REGISTER
         MBS,R2   0                 MOVE DDD PORTION TO NEW CLUSTER
         LW,R1    DPONTR            DDD POINTER
         LI,R2    HA(CRFBUILD)      CRF BUFFER ADDR
         BAL,R11  RCORDV            RESOLVE VAR REC
         MTW,0    PDBDBG                                                COBOL31
         BEZ      BALPAD                                                COBOL31
         LH,R13   REF#              PICK UP SAVED REF#                  COBOL31
         LI,R4    HA(CRFBUILD)                                          COBOL31
         AI,R4    1                                                     COBOL31
         STH,R13  1,R4              STORE REF# IN CRF CLUSTER           COBOL31
BALPAD   RES      0                                                     COBOL31
         BAL,R11  PADDLE            APPEND FILLER AND INSERT NEW LENGTH
         B        REFEXIT
XRFU     STW,R11  NESTRET2
         LW,R1    R2                ADDRESS OF ORIGINAL CLUSTER
         SLS,R1   -1                HALF WORD ADDRESS
XRNO     LH,R15   1,R1              LOAD REFERENCE NUMBER
         BLZ      QINC              QUALIFIER
         STH,R15  XRFBUILD,UP1      SIMPLE NAME- STORE IN XRF CLUSTER
EXRF     LW,R14   ALLBITS           PUT ALL BITS
         STW,R14  LINENTRY              INTO DEF. LINE NUMBERS
XRFDENT  STH,R13  XRFBUILD          LENGTH AND CROSS REFERENCE CODE
         LI,R13   X'2000'           IS XREF
         AND,R13  PDBCC                 OPTION REQUESTED
         BEZ      %+3               NO- RETURN
         LI,R4    BA(XRFBUILD)      PUT OUT
         BAL,R11  WRXRF                 THE CROSS REFERENCE
         B        *NESTRET2         RETURN
QINC     AI,R1    1                 INCREMENT TO
         B        XRNO                  NEXT REFERENCE NUMBER
XRFD     STW,R11  NESTRET2
         B        XRFDENT           DEF FOUND AND INFO STORED ALREADY
         PAGE
CORRES   AND,CBYT L(X'7F')
         CI,CBYT  X'74'             IS THIS A REFERENCE
         BL       TOMAIN            WITHIN A MOVE,ADD OR SUBTRACT
         CI,CBYT  X'77'             CORRESPONDING OR SOURCE IS SLEECTED
         BG       TOMAIN            IF NOT RETURN TO CALLING PROGRAM
*        IF NOT FIRST CLUSTER FLAG AS RECEIVING GROUP
         LB,R13   CLUNO,UP1          SIDR 771
         SLS,R13  -7                 SIDR 771
         EOR,R13  R7                 SIDR 771
         STW,R13  STOPPER           SAVE IT
         LW,R3    SAVEREG           IS THIS A
         CI,R3    2                     SUBSCRIPT DATA NAME
         BE       TOMAIN            IF SO RETURN TO CALLING PROGRAM
         CI,OTYP  9                 IS THE NAME RESOLVED
         BNE      UNRECOR           NO- PUT OUT SPECIAL CLUSTER
         STW,UP1  CORRESP           TURN ON FLAG IN 3.0
         MTW,0    PDBDBG            SEE IF DEBUGGING
         BEZ      WHERE1
         LW,R3    R2                ADDRESS OF CLUSTER
         AI,R3    2
         LB,R15   0,R3
         CI,R15   X'90'
         BL       WHERE1            DO NOT COMPRESS
         CI,R15   X'92'
         BG       WHERE1
         LI,R15   BA(NEWSAV)        TEMP WORK AREA FOR COMPRESSING CLUS
         OR,R15   COUNT6            MOVE FIELDS A,B,C,D,E
         LW,R14   R2
         MBS,R14  0
         AI,R14   2                 SKIP REFERENCE NUMBER
         LB,R3    0,R2              SIZE IN H.W.
         SLS,R3   1                 SIZE IN BYTES
         AI,R3    -8                ADJUST SIZE OF CLUSTER
         STB,R3   R15               SIZE FOR MOVING REST OF CLUSTER
         MBS,R14  0
         AI,R3    6                 SIZE OF CLUSTER
         SLS,R3   -1
         STB,R3   NEWSAV
         STW,R2   R2SAV             SAVE R2
         LI,R2    BA(NEWSAV)
WHERE1   RES      0
         LW,R1    R2                ADDRESS OF CRF CLUSTER
         LW,R4    R2                ACCESS
         AI,R4    6                    FIELDS
         LB,R13   0,R4                 H AND I
         CI,R13   X'F'              CHECK CLASS
         BANZ     ELEMCOR           NOY A GROUP
         AI,R1    1                 PICK UP
         LB,R13   0,R1                  CONTROL BYTE
         STB,R13  1,R2              PUT IT INTO FIELD E
         LI,R14   X'40'             CODE FOR GROUP IN CORRESPONDING
         OR,R14   STOPPER           41 IF 'TO' GROUP
         STB,R14  0,R1              PUT INTO CONTROL BYTE FIELD
         LW,R4    R2                SET OUTPUT REGISTER TO MODIFIED CRF
         BAL,R11  WHERE
         STW,R6   CGPOINT           SAVE ADDRESS OF GROUP DDD ENTRY
         STB,R13  0,R1              RESTORE CONTROL BYTE IN CRF CLUSTER
         LB,R13   *R6               LOAD LENGTH OF GROUP DDD SEGMENT
         LW,R14   2,R6              SAVE END OF RANGE
         AND,R14  LOW24                 OF GROUP
         AW,R14   SAVERG5
         STW,R14  CSE                   IN CSE
         LI,R14   3
         AND,R14  3,R6              NUMBER OF DIMENSIONS
         STB,R14  CSD                   IN CSD
NXTSUB   AW,R6    R13               INCREMENT TO NEXT SUBORDINATE ENTRY
         CW,R6    CSE               END OF GROUP ENTRIES
         BGE      TOTRAIL           PUT OUT GROUP TRAILER
         LB,R13   *R6               LENGTH OF THIS ENTRY
         LW,R14   2,R6              LOAD LEVEL NUMBER AND END OF RANGE
         SLS,R14  -24               SHIFT LEVEL NUMBER TO LOW ORDER
         CI,R14   50                IS IT GREATER THAN 49
         BGE      NONXT             YES- PROCESS NEXT AT EQ. OR L LEVEL
         LI,R14   3
         AND,R14  3,R6              NUMBER OF DIMENSIONS
         CW,R14   CSD               IS IT GREATER THAN THAT FOR GROUP
         BG       NONXT             IF SO PROCESS NEXT
         LI,R1    HA(SAVBUF)        FORMAT CSF CLUSTER IN SAVBUF
         LI,R12   X'0042'           CODE FOR CORRESPONDING SUBORDINATE
         OR,R12   STOPPER           43 IF 'TO' GROUP SUBORDINATE
         STH,R12  0,R1              INTO BYTE 1 OF CLUSTER
         LW,R4    R6                ADDRESS OF SUBORDINATE DDD ENTRY
         LI,R5    BA(SAVBUF)+2      DESTINATION ADDRESS
         LI,R12   6
         STB,R12  R5                TO COUNT POSITION OF DESTIN. REG.
         AI,R4    2                 INCREMENT SOURCE ADDRESS TO
         SLS,R4   2                 BYTE ADDRESS OF FIELD E
         MBS,R4   0                 MOVE TO SAVBUF
         CI,CBYT  X'77'
         BE       %+2               SOURCE SELECTED
         AI,R5    2
         LW,R12   R13
         SLS,R12  2
         AI,R12   -14
         STB,R12  R5
         MBS,R4   0                 FROM H ON TO SAVBUF
         LCI      3
         STM,R1   VREGS
         LW,R3    R5
         CI,CBYT  X'77'
         BE       NXTSSL            SOURCE SELECTED
         LW,R4    SAVBUF+1          SAVE F OF CSF
         LW,R1    R6                DDD ADDRESS
         LI,R2    HA(SAVBUF)        CLUSTER ADDRESS
         BAL,R11  RCORDV            RESOLVE VAR REC
         XW,R4    SAVBUF+1          RESTORE F OF CSF
         SLS,R4   -16
         LI,R2    X'FFF3'
         AND,R2   SAVBUF+2          GET RID OF VAR FLAG
         STH,R4   R2
         STW,R2   SAVBUF+2
NXTSSL   AI,R3    2-BA(SAVBUF)
         SLS,R3   -1                CLUSTER LENGTH
         STB,R3   SAVBUF
         LCI      3
         LM,R1    VREGS
         LI,R4    BA(SAVBUF)
         BAL,R11  WHERE
         B        NXTSUB            PROCESS NEXT ENTRY IF ANY
TOTRAIL  CI,CBYT  X'77'             IS IT SOURCE SELECTED
         BE       TOMAIN            YES-NO TRAILER NECESSARY
         LI,R3    BA(TRAILCOR)+1    PUT STATEMENT OPTIONS
         STB,CBYT 0,R3                 INTO CLUSTER
         AI,R3    2                 PUT CODE
         LI,R13   X'40'                INTO STATEMENT OPTIONS
         OR,R13   STOPPER           41 IF 'TO' GROUP
         STB,R13  0,R3
         LI,R13   X'0409'           WRITE OUT
         STH,R13  CSFLINE,UP1          A LINE NUMBER
         LI,R4    BA(LINENTRY)         CLUSTER FOR
         BAL,R11  *CFILEOUT         3.3 DIAGNOSTICS
         LI,R4    BA(TRAILCOR)      OUTPUT TRAILING CLUSTER
         BAL,R11  WHERE
         B        TOMAIN            RETURN
NONXT    LW,R6    2,R6
         AND,R6   LOW24
         AW,R6    SAVERG5           BASE OF DDD                         COBOL31
         B        NXTSUB+1          TRY NEXT ENTRY
WHERE    STW,R11  NESTRET2          SAVE RETURN
         CI,CBYT  X'77'  IS IT SOURCE SELECTRD
         BNE      %+3    NO
         BAL,R11  WRCRF  PUT OUT ON CRF
         B        *NESTRET2         RETURN
         BAL,R11  *CFILEOUT         PUT ON APPROPRIATE FILE
         B        *NESTRET2         RETURN
         PAGE
UNRECOR  LW,R13   LSN               IS THIS THE LAST PASS
         BNEZ     TOMAIN            IF NOT RETURN TO CALLING PROGRAM
ELEMOUT  RES      0
         LW,R13   ELEMUND           SYNTAX ONLY CLUSTER
         OR,R13   STOPPER           'FROM' OR 'TO' GROUP INDICATOR
         STW,R13  TRAILCOR             INTO CLUSTER
         LI,R4    BA(TRAILCOR)      OUTPUT ON APPROPRIATE FILE
         BAL,R11  WHERE
         B        TOMAIN            RETURN
ELEMCOR  AI,R4    -4                ACCESS OPERAND OTIONS
         LI,R13   X'91'                CHANGE TO CONDITION NAME
         STB,R13  0,R4              TO FORCE PHASE 4 DIAGNOSTIC
         B        ELEMOUT           PUT OUT AN UNDEFINED CLUSTER ON CSF
         PAGE
*        FLAGS, COUNTERS, FIELD SAVE AREAS
         BOUND    4
COUNT8   DATA     X'08000000'       COUNT FOR 4 BYTE MBS
COUNT4   DATA     X'04000000'       COUNT FOR 8 BYTE MBS
COUNT6   DATA     X'06000000'       COUNT FOR 6 BYTES                   COBOL31
REF#     DATA     0                                                     COBOL31
QBIT     DATA     X'00008000'
NUMBERS  RES      0
INLBR    DATA,2   0                 RANGE NUMBER
SECNO    DATA,2   0                 SECTION NUMBER
FLAGS1   RES      0
BYTO     EQU      FLAGS1
JTJF     EQU      FLAGS1
OJTJF    EQU      FLAGS1
QORN     DATA,1   0                 DATA NAME OR QUALIFIER INDICATOR
         DATA,1   0                 FLAG INDICATING DIVIDE BY OR INTO IN
         DATA,1   0                 'VARY' COUNT IN PERFORM
         DATA,1   0                 ACCUMULATIVE VARY COUNT
FLAGS2   RES      0
CLUNO    EQU      FLAGS2
ERSFLG   EQU      FLAGS2
WCHBUF   EQU      FLAGS2
QFLG     DATA,1   0                 NON ZERO MEANS NAME WAS QUALIFIED
         DATA,1   0                 FIRST CLUSTER OF STATEMENT IND.
         DATA,1   0                 BAD STATEMENT FLAG
         DATA,1   0                 OUTPUT ROUTINE FLAG
FLAGS3   RES      0
SUBS     EQU      FLAGS3
NEWS     EQU      FLAGS3
PSFLAG   EQU      FLAGS3
NUR      DATA,1   0                 NON UNIQUE REFERENCE FLAG
         DATA,1   0                 NO. OF SUBSCRIPTS PER NAME
         DATA,1   X'80'             NEW STATEMENT INDICATOR
         DATA,1   0                 FLAG TO SAVE PERFORM CLUSTER
FLAGS4   RES      0
SUBJECT  EQU      FLAGS4
ENTCNT   EQU      FLAGS4
USER     EQU      FLAGS4
GIVER    DATA,1   0
         DATA,1   0
         DATA,1   0
         DATA,1   0
         BOUND    4
TLRPF    DATA     0                 TALLY/REPLACING FLAG                COBOL31
INCHF    DATA     0                 CHARACTERS/SIZE FLAG                COBOL31
INTO:FLG DATA     0                 INTO:PRESENT FLAG                   COBOL31
*THIS CELL CONTAINS NO. CLUSTERS SAVED TO GO AHEAD OF STATEMENT
*BYTE 0 IS ON SIZE ERROR FLAG
SAVER    GEN,32   0
*        ADDRESS CONSTANTS
OCCR     GEN,32   0                 SAVE RETURN
SAVPTR   GEN,32   BA(SAVBUF)
CPTR     GEN,32   HA(CLIST)         NEXT AVAILABLE REFERENCE NUMBER
PNTR1    DATA     0                 DELIM SUBSCRIPT SAVE                COBOL31
PNTR2    DATA     0                 IDENT SUBSCRIPT SAVE                COBOL31
STRNGSAV DATA     0                 STRING SUBROUTINE RTN SAV           COBOL31
*        CONSTANTS AND MASKS USED BY GETDEF
CGPOINT  GEN,32   0
CSE      GEN,32   0                 END OF RANGE OF CORRESPONDING GROUP
CSD      GEN,32   0
RBYST    DATA     X'0300000D'
ELEMUND  DATA     X'03080000'
STOPPER  DATA     0                 SAVE FOR STOP MASK
LOFIFTN  DATA     X'00007FFF'
SEGN     DATA     X'00FFC000'
DISPL    DATA     X'00003FFF'
COUNT3   DATA     X'03000000'
COUNT2   DATA     X'02000000'
LOW24    DATA     X'00FFFFFF'
ALLBITS  DATA     X'FFFFFFFF'
LOW10    DATA     X'000003FF'
         BOUND    4
TRAILCOR GEN,32   X'03000000'
         GEN,16   X'FF03'
         BOUND    4
SAVEREG  RES      6
FLAGD1   RES      0
RSAVE    EQU      SAVEREG           SAVED REF. TYPE
*ADDRESS CONSTANTS
NESTRET1 GEN,32   0                 FOR NESTED
NESTRET2 GEN,32   0                     SUBROUTINE EXITS
NESTRET3 GEN,32   0
CFILEOUT GEN,32   WA(WRCRF)         OUTPUT FILE ADDRESS FOR CORRES
         BOUND    8
SB1      GEN,32   0                 LOW LIMIT DICTIONARY SEARCH
SB2      GEN,32   0                 UPPER LIMIT DICTIONARY SEARCH
         PAGE
*        BUFFERS FOR SAVING CLUSTERS-AND STATEMENTS
         BOUND    2
JTJFC    RES,2    4                 JUMP TRUE/FALSE CLUSTER
ONSZR    RES,2    4                 ON SIZE ERROR
         BOUND    2
ONEW     RES      1                                                     COBOL31
NEWCL    RES,1    4                 COMPOSITE
CLIST    RES,2    50                    CLUSTER
CRFBUILD RES,2    400               CRU BUFFER
SVSRCH   RES,2    4                          AREA
         BOUND    4
SAVBUF   RES      300
DDELM    DATA     0                 STRING DELIMITER SAVE AREA          COBOL31
NEWSAV   RES      75
R2SAV    DATA     0                 STORE R2 FOR CORRES
ENDSV    GEN,32   0
GOTODP   DATA     0
DPONTR   DATA     0                 DDD WORD POINTER
REMF     DATA     0                 REMAINDER FLAG
VREGS    RES      3
*DLAREA1,2 RES     REMOVED  SIDR 1954
         END      START
