         SYSTEM   SIG7FDP
         TITLE    'PHASE 2.2 PROCEDURE DICTIONARY RESERVATION FACTOR'
*
BUFAREA  EQU      8000
*
         TITLE    'PHASE 2.2 WORK AREAS ETC'
*
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
*
         DEF      COB22
*
         REF      PDBCC
         REF      PDBO
         REF      PDBP
         REF      PDBZ
         REF      PH22E
         REF      RDEPF
         REF      RDSPD
         REF      WRPDD
         REF      WRXRF
         REF      PDBS,WRPOF
         REF      PRI               RPIORITY SEGMENTATION TABLE
         REF      DIAG              DIAGNOSTIC ROUTINE
         REF      ON:LINE
POFBUF   RES      10                POF BUFFER
CURPDD   RES      1                 PDD CURRENT ADDRESS
XRFSW    GEN,32   0            XRF SWITCH
ADD3     GEN,32   0                AUX ADDR STORE GETEPF
SITAD    GEN,32   0           ADDRESS OF SIT
LSTSEG   GEN,32   0           LAST SEGMENT NUMBER
TRACESW  GEN,32   0           TRACE SWITCH
DECLAR   GEN,32   0           DECLARATIVES SWITCH
PRESLO   DATA     PDDBUF            ADDRESS OF PDD BUFFER AREA
PROCNO   GEN,32   0           PROCEDURE DEFINITION NUMBER
SITADP   GEN,32   0           PRESENT SIT ITEM - HALF WORD ADDRESS
PTYPE    GEN,32   0           PROCEDURE TYPE  1=SECTION 0=PARAGRAPH
DISPL    GEN,32   0           DISPLACEMENT
ADINDEX  GEN,32   0          USED TO SAVE ADDRESS OF DINDEX
PRESEC   GEN,32   0           PRESENT SECTION
PASWT    GEN,32   0           I/O SWITCH
PROSAV   GEN,32   0           AUX STORAGE FOR PROCEDURE LOCATION
PROSEG   GEN,32   0           AUX STORAGE FOR PROCEDURE PRIORITY
LSTPRIOR GEN,32   0           LAST PRIORITY NUMBER
PSTSEG   GEN,32   0           FIRST SEGMENT NUMBER + 1
ADD1     GEN,32   0                 AUX ADDRESS STORE
ADD2     GEN,32   0                 AUX ADDRESS STORE
LIM1     GEN,32   0                 LO QUALIFIER LIMIT
LIM2     GEN,32   0                 HI QUALIFIER LIMIT
P1AD     GEN,32   0           ADDRESS OF P1 PDD ENTRY
P1OV     GEN,32   0           PRIORITY OF P1
P2OV     GEN,32   0           PRIORITY OF P2
INIT     GEN,32   0                 FLAG TO SELECT START LOCATION
         TITLE    'INITIALIZE PHASE 2.2'
COB22    RES      0
         LI,R3    1                 X
         LI,R1    0                 X
P1       AI,R1    1                 X  DERIVE DENSE SET OF SEGMENT #S
         CI,R1    100               X   FROM SOURCE PROGRAM PRIORITY
         BE       P2                X   VALUES
         LB,R2    PRI,R1            X
         BEZ      P1                X
         STB,R3   PRI,R1            X
         AI,R3    1                 X
         B        P1                X
P2       RES      0                 X
         LW,R2    PDBZ+2     X
         SLS,R2   -2         X GET AND SAVE WA( DINDEX )
         STW,R2   ADINDEX    X
         LH,R3    PDBP         GET NO. OF PROC DIV SECTIONS
         MI,R3    3           X
         AI,R3    3           X CALC SIZE OF SIT AREA + 1
         SLS,R3   -1          X
         LCW,R2   R3                   X CALC EXPECTED LOCATION OF
         AW,R2    ADINDEX              X SIT
         CW,R2    PDBZ             X ABORT IF NOT ENOUGH MEMORY
         BL       OPPS             X
         STW,R2   SITAD
         AI,R2    -1               X
         LI,R4    -1               X SET SIT AREA TO ALL BITS
BILOOP   STW,R4   *R2,R3           X
         BDR,R3   BILOOP           X
         LW,R2    PDBO               X
         SLS,R2   8                  X GET + SAVE NO. OF LAST DDD
         SLS,R2   -22                X SEGMENT
         STW,R2   LSTSEG             X
         AI,R2    1          X SET PSTSEG
         STW,R2   PSTSEG     X
         LI,R2    X'800'          X
         AND,R2   PDBCC           X
         BEZ      NOTRACE         X SET TRACESW IF DEBUG OPTION IS ON
         LI,R2    X'8000'         X AND TRACE VERB IS PRESENT
         AND,R2   PDBP            X
         STW,R2   TRACESW         X
         MTW,0    ON:LINE
         BEZ      NOTRACE
         MTW,4    TRACESW           FORCE TRACE IF ON-LINE DDBUG
NOTRACE  RES      0
         LI,R2    X'2000'    X
         AND,R2   PDBCC      X SET XRFSW IF XRF LIST CALLED FOR
         STW,R2   XRFSW      X
         TITLE    'PROCESS SPD'
         LW,R2    SITAD          X
         SLS,R2   1              X SET UP HALF WORD ADDRESS
         AI,R2    -3             X TO INITIALIZE SIT
         STW,R2   SITADP         X
LOOPA    BAL,11   RDSPD
         BL       SECT3A            EXIT IF EOF
         LW,10    R2         SAVE LOC FOR XRF DECISION
         LW,R3    R2               X
         AI,R3    9                X
         LB,R4    0,R3             X CALC EXPECTED PDD ENTRY SIZE
         AI,R4    20               X
         SLS,R4   -2               X
         LW,R8    R4                  X
         AW,R4    PRESLO              X ABORT IF THERE IS NOT ENOUGH
         CW,R4    PDDEND              X CORE TO HOLD PDD
         BGE      OPPS                X
***********************************************************************
*       TRANSFER SPD INFORMATION TO PDD ENTRY
*
         LW,R3    PRESLO     R3 = WA OF OUT
         STW,R3   CURPDD            FOR POF CLUSTER
         AI,R2    1          R2 = BA OF IN + 1
         LB,R6    0,R2       LOAD CONTROL BYTE
         STB,R6   *R3        STORE CONTROL BYTE
         LI,R5    0       X
         STW,R5   PTYPE   X SET PTYPE ACCORDING TO CONTROL BYTE
         CI,R6    X'96'   X
         BE       PARO    X
         STW,R6   PTYPE   X
PARO     AI,R2    1
         SLS,R2   -1                 R2 = HA OF IN + 1
         LH,R6    0,R2       LOAD SOURCE LINE NO.
         STW,R6   15                SAVE  FOR XRF
         SLS,R3   1          R3 = HA OF OUT
         STH,R6   1,R3       STORE SOURCE LINE NO.
         LH,R7    1,R2       LOAD REF NO.
         STH,R7   13                X
         LI,12    X'0501'          X FINISH 1ST WORD OF XRF CLUSTER
         SLD,12   -16               X
         AI,R2    1          R2 = HA OF IN +2
         AI,R3    3          R3 = HA OF OUT + 3
         LH,R6    0,R2       LOAD COPY LINE NO.
         STW,R6   14                STORE IN XRF OUTPUT AREA
         STH,15   14                SOURCE LINE NO TO XRF OUTPUT
         STH,R6   0,R3       STORE COPY LINE NO.
         LH,R4    1,R2       LOAD F AND G
         LI,R5    0
         SLD,R4   -8         SPLIT F AND G
         AI,R3    1          R3 = HA OF OUT + 4
         LB,R4    PRI,R4            GET TRUE SEGMENT NO.
         STH,R4   0,R3       STORE F
         LI,R1    1        X
         AW,R1    PROCNO   X BUMP PROCNO
         STW,R1   PROCNO   X
         AI,R3    1          R3 = HA OF OUT + 5
         STH,R1   0,R3       STORE PROC DEF NO
         LI,R1    0
         STH,R1   1,R3       CLEAR I
         AI,R3    1          R3 = OUT + 6
         STH,R1   0,R3       CLEAR H
         AI,R2    3          R2 = IN + 5
         SLS,R2   1          R2 = BYTE ADDRESS
         LH,R4    R5
         STH,R4   1,R3       STORE NO. OF BYTES
         SLS,R3   1         R3 = BA OF OUT + 12
         AI,R3    5          R3 = BA OF OUT + 17
         OR,R3    R5         R5 = LENGTH OF BCD IN BYTES
         MBS,R2   0          MOVE BCD PROC NAME
***********************************************************************
*      CREATE SIT ENTRY AND LINK INTO DINDEX
*
         LW,R4    PTYPE             X
         BEZ      NONSECT           X
         BAL,11   COUNT             X
         LI,R2    0                 X
         STW,R2   DISPL             X
         AI,R5    3                 X
         STW,R5   SITADP            X
         LW,R2    LSTSEG            X
         AI,R2    1                 X
         STW,R2   LSTSEG            X CREATE SIT ENTRY
         SLD,R2   -8                X
         STH,R2   0,R5              X
         SLD,R2   8                 X
         LW,R3    PRESLO            X
         SLS,R3   8                 X
         SLD,R2   8                 X
         AI,R5    1                 X
         STH,R2   0,R5              X
         LH,R2    R3                X
         AI,R5    1                 X
         STH,R2   0,R5              X
NONSECT  LI,R5    0                    X
         LB,R4    *ADINDEX,R7          X
         AI,R7    1                    X
         LB,R5    *ADINDEX,R7          X
         SLS,R5   24                   X
         SLD,R4   8                    X TRANSFER DINDEX DATA TO
         AI,R7    1                    X SYNONYM LINKAGE FIELD OF
         LB,R5    *ADINDEX,R7          X PDD ENTRY
         SLS,R5   24                   X
         SLD,R4   8                    X
         LW,R5    L(X'FF000000')       X
         AND,R5   *PRESLO              X
         OR,R4    R5                   X
         STW,R4   *PRESLO              X
         LW,R5    LSTSEG            X
         SLS,R5   14                X
         OR,R5    DISPL             X
         STB,R5   *ADINDEX,R7       X
         SLS,R5   -8                X PUT  PDD ADDRESS IN DINDEX
         AI,R7    -1                X
         STB,R5   *ADINDEX,R7       X
         SLS,R5   -8                X
         AI,R7    -1                X
         STB,R5   *ADINDEX,R7       X
         AWM,R8   DISPL      X BUMP BY ENTRY SIZE
         AWM,R8   PRESLO     X
         LW,R5    XRFSW
         BEZ      TRCTST
         LW,R5    10         X
         AI,R5    10         X
         LB,R5    0,R5       X DO NOT OUTPUT XRF ENTRY FOR CREATED
         EOR,R5   L(X'5B')   X PROC NAMES
         BEZ      TRCTST     X
         LI,R4    52                X OUTPUT XRF
         BAL,11   WRXRF             X
TRCTST   LW,R5    TRACESW
         BEZ      LOOPA
         LW,R2    L(X'002D0400')    FORM POF CLUSTER
         STW,R2   POFBUF            C, B PART
         LW,R5    CURPDD
         AI,R5    4
         LB,R2    *R5
         STB,R2   R3
         AI,R2    1
         SLD,R2   -24
         LH,R2    PDBS
         AI,R2    3
         AND,R2   L(X'FFFFFFFC')    MASK OUT LAST 2 BITS
         STH,R2   R3
         STW,R3   POFBUF+1          D,J PART
         AI,R5    -1
         STH,R2   *R5               UPDATE H OF PDD
         AI,R5    1
         LB,R4    *R5
         LI,R3    BA(POFBUF+2)
         STB,R4   R3
         AI,R4    1
         AW,R2    R4
         STH,R2   PDBS              UPDATE PDBS
         AI,R4    9
         SLS,R4   -1
         STB,R4   POFBUF            A OF POF
         LW,R2    R5
         SLS,R2   2
         MBS,R2   1                 K OF POF
         LI,R4    BA(POFBUF)
         BAL,11   WRPOF
         B        LOOPA
***********************************************************************
*    COUNT        TRANSFER VALUE FROM DISPL TO SIT
*
COUNT    LW,R2    DISPL      GET DISPL
         SLS,R2   2            ALIGN
         LW,R5    SITADP       GET HA OF SIT ENTRY
         LH,R4    0,R5        GET LENGTH FIELD
         AND,R4   L(3)           DROP POSSIBLE GARBAGE
         OR,R2    R4
         STH,R2   0,R5       SIT ITEM IS NOW COMPLETE
         B        *11
***********************************************************************
*    SECT3A       WRAP UP SPD PROCESSING
*
SECT3A   RES      0
         BAL,11   COUNT       FINISH LAST SIT ENTRY
         LI,R4    0               X STORE ZERO WORD AFTER PDD
         STW,R4   *PRESLO         X
         TITLE    'READ AND PROCESS EPF'
***********************************************************************
*              MAIN LOGIC LOOP
*
SECT3    RES      0
         BAL,11   GETEPF
SECT3S   AI,R2    1
         LB,R3    0,R2       GET CONTROL BYTE
         AI,R2    -1
         CI,R3    X'F3'        TEST FOR PROCEDURE DEFINITION
         BE       PROCDEF
         CI,R3    X'F2'        TEST FOR DECLARATIVES
         BE       DECLTV
         CI,R3    X'D8'        TEST FOR ENTER COBOL
         BE       ENTCB
         CI,R3    X'E1'        TEST FOR PERFORM
         BE       PERF
         CI,R3    X'EC'        TEST FOR USE
         BE       UZ
         CI,R3    X'E8'        TEST FOR SORT
         BE       SRT
         CI,R3    X'D2'        TEST FOR ALTER
         BNE      SECT3     OTHERWISE FALL INTO ALT
*    ALT          PROCESS ALTER
************************************************************************
*
ALT      BAL,11   RESOLV
         BE       ALT1        BRANCH IF DEFINED
         BAL,11   GETEPF            X IF UNDEFINED SKIP TO
         BAL,11   RESOLV            X PROCEED TO CLAUSE
         B        SET00
ALT1     STW,R4   P1AD             SAVE PDD ADDRESS
         LI,R3    8
         LB,R5    *R4,R3     X
         OR,R5    L(X'40')   X SET ALTER BIT
         STB,R5   *R4,R3     X
         LI,R3    9               X
         LB,R3    *R4,R3          X SAVE PRIORITY NUMBER
         STW,R3   P1OV            X
         BAL,11   XSET           SET UP AN EXIT NO
ALT1A    RES      0                                                     COBOL22
         BAL,11   GETEPF
         AI,R2    1          X
         LB,R3    0,R2       X
         AI,R2    -1         X EXIT IF STATEMENT IS NOT COMPLETE
         CI,R3    X'52'      X
         BNE      SECT3S     X
         AI,R2    2                                                     COBOL22
         LB,R3    0,R2                                                  COBOL22
         AI,R2    -2                                                    COBOL22
         CI,R3    X'9B'             SEE IF THIS NAME CLUSTER FOR        COBOL22
         BE       ALT1A             DEBUG MODULE-BYPASS                 COBOL22
         BAL,11   RESOLV
         BE       ALT2              X IF UNDEFINED FORCE IT TO BE
         LI,R3    0                 X IN THE ROOT SEGMENT
         B        ALT3
ALT2     LI,R3    9               X
         LB,R3    *R4,R3          X SAVE P2 PRIORITY NUMBER
ALT3     STW,R3   P2OV            X
         LW,R1    LSTPRIOR    GET PRIORITY OF ALTER STATEMENT
         BNEZ     CASE2
         LW,R1    P1OV        GET PRIORITY OF P1
         BNEZ     CASE3
         LW,R1    P2OV       GET PRIORITY OF P2
         BNEZ     SET10
SET00    BAL,11   GETEPF            X
         AI,R2    1                 X
         LB,R3    0,R2              X
         AI,R2    -1                X LOOP IF ALTER HAS ADDITIONAL
         CI,R3    X'52'             X OPERANDS
         BNE      SECT3S            X
         AI,R2    2                                                     COBOL22
         LB,R3    0,R2                                                  COBOL22
         AI,R2    -2                                                    COBOL22
         CI,R3    X'9B'             SEE IF THIS NAME CLUSTER FOR        COBOL22
         BE       SET00             DEBUG MODULE-BYPASS                 COBOL22
         B        ALT               X
SET01    LI,R2    8          X
         LB,R3    *P1AD,R2   X
         OR,R3    L(X'01')   X SET BITS 6-7 OF E TO 01
         STB,R3   *P1AD,R2   X
         B        SET00      X
SET10    LI,R2    8            X
         LB,R3    *P1AD,R2     X
         OR,R3    L(X'02')     X SET BITS 6-7 OF E TO 10
         STB,R3   *P1AD,R2     X
         B        SET00        X
SET11    LI,R2    8          X
         LB,R3    *P1AD,R2   X
         OR,R3    L(X'03')   X SET BITS 6-7 OF E TO 11
         STB,R3   *P1AD,R2   X
         B        SET00      X
*  CASE3 IS ENTERED IF ALTER STMNT IS IN ROOT AND P1 IS NOT
CASE3    CW,R1    P2OV
         BE       SET10
         LW,R1    P2OV
         BEZ      SET01
         B        SET11
*  CASE2 IS ENTERED IF ALTER IS NOT IN ROOT
CASE2    CW,R1    P1OV
         BE       CASE4
         LW,R2    P1OV
         BEZ      CASE5
         CW,R2    P2OV
         BE       SET10
         LW,R2    P2OV
         BEZ      SET01
         B        SET11
*  CASE4 IS ENTERED IF ALTER IS NOT IN ROOT AND HAS PRIORITY = P1
CASE4    CW,R1    P2OV
         BE       SET10
         LW,R1    P2OV
         BEZ      SET01
         B        SET11
*  CASE5 IS ENTERED IF ALTER STMNT IS NOT IN ROOT AND P1 IS.
CASE5    LW,R1    P2OV
         BEZ      SET00
         B        SET11
************************************************************************
*    CHAIN        FIND LOCATION CORRESPONDING TO SEG NO AND DISP
*
*    INPUT        SEG NO AND DISPL IN R6
*    OUTPUT       PDD ENTRY ADDRESS IN R3
*
CHAIN    LI,R7    0
         CI,R6    0                 X
         BNE      CHAIN1            X IF UNDEFINED RETURN NO
         LCI      3                 X
         B        *11               X
CHAIN1   SLD,R6   -14                SPLIT SEG NO AND DISP
         SW,R6    PSTSEG     X
         BGEZ     GDSEG      X RETURN NO IF SEG NUMBER IS OUT OF
         LCI      3          X RANGE
         B        *11        X
GDSEG    LW,R3    R6           X
         MI,R3    3            X
         AI,R3    1            X
         LH,R2    *SITAD,R3    X
         AI,R3    1            X LOOK UP SEGMENT ADDRESS
         LH,R3    *SITAD,R3    X
         SLS,R3   16           X
         SLD,R2   -8           X
         SLS,R3   -8           X
         SLS,R7   -18            X
         AW,R3    R7             X CALC LOCATION
         LCI      0              X AND RETURN
         B        *11            X
************************************************************************
*    DECLTV       PROCESS DECLARATIVES FLAG
*
DECLTV   AI,R2    3
         LB,R3    0,R2              X SET OR RESET DECLAR DEPENDING
         STW,R3   DECLAR            X ON TYPE OF DECLARATIVES CLUSTER
         B        SECT3
************************************************************************
*    ENTCB        PROCESS ENTER COBOL
*
ENTCB    BAL,11   RESOLV
         BNE      ENTCB1      BRANCH IF NOT DEFINED
         BAL,11   XSET              SET UP AN EXIT NO.
         LI,R1    8                 TURN ON BIT 0 OF E FIELD
         LB,R3    *R4,R1             DENOTING AN
         OR,R3    L(X'80')            EXTERNAL
         STB,R3   *R4,R1               DEFINITION
ENTCB1   BAL,11   GETEPF
         AI,R2    1                 X
         LB,R3    0,R2              X
         CI,R3    X'58'             X LOOP IF STILL IN ENTER
         BE       ENTCB             X
         STW,R2   PASWT             SET INPUT BACK ONE
         B        SECT3
************************************************************************
*    GETEPF       GET AN EPF CLUSTER
*
GETEPF   LW,R7    PASWT
         BNEZ     HAV     BRANCH IF RECORD HAS ALREADY BEEN READ
         STW,11   ADD1
HZER     BAL,11   RDEPF
         BL       SECT4             EXIT IF EOF
         AI,R2    1          X
         LB,R7    0,R2       X
         AI,R2    -1         X SKIP CARD NO CLUSTERS
         CI,R7    0          X
         BE       HZER       X
         AI,R2    2                 X   TEST FOR
         LB,R7    0,R2              X   STATEMENT CANCELLATION CLUSTER.
         AND,R7   L(X'70')          X   IF IT IS DROP EVERYTHING
         CI,R7    X'70'             X   AND RETURN TO MAIN LOGIC LOOP
         BE       SECT3             X   FOR NEXT STATEMENT
         AI,R2    -2                X
         STW,R2   ADD3        SAVE CLUSTER ADDRESS
         B        *ADD1
HAV      LI,R7    0
         STW,R7   PASWT             CLEAR PASWT
         LW,R2    ADD3              GET CLUSTER ADDRESS
         B        *11
************************************************************************
*    PERF         PROCESS PERFORM
*
PERF     BAL,11   RESOLV           X
         BE       PERF2            X RESOLVE PROCEDURE NAME
         LI,R4    0                X
PERF2    STW,R4   PRESLO             X
         BAL,11   GETEPF             X
         AI,R2    1                  X
         LB,R3    0,R2               X
         AI,R2    -1                 X
         CI,R3    X'61'              X
         BNE      PERF3              X
         AI,R2    2                  X TEST FOR AND PROCESS THRU
         LB,R3    0,R2               X OPTION
         AI,R2    -2                 X
         CI,R3    X'84'              X
         BNE      PERF3              X
         BAL,11   RESOLV             X
         BE       PERF4              X
PERF3    LI,R3    1                 X
         STW,R3   PASWT             X
         LW,R4    PRESLO            X IF THRU OPTION NOT PRESENT
         BEZ      SECT3             X OR UNDEFINED
* CAUTION   UZ EQU PERF4
PERF4    BAL,11   XSET
         LI,R1    8                X
         LB,R3    *R4,R1           X
         OR,R3    L(X'20')         X PICK BIT 2 OF PROCEDURE REF FIELD
         STB,R3   *R4,R1           X
PERF5    LI,R5    9                 X
         LB,R2    *R4,R5            X GET PRIORITY OF P1
         LW,R3    LSTPRIOR     GET PRIORITY OF SECT WE ARE IN
         BNEZ     PERF6
         CI,R2    0
         BEZ      SECT3   EXIT IF PERFORM AND P1 ARE IN ROOT
PIK11    LB,R3    *R4,R1            X
         OR,R3    L(3)              X SET BITS 6+7 OF E TO 11
         STB,R3   *R4,R1            X
         B        SECT3
*    PERF6 IS ENTERED IF PERFORM STMNT IS NOT IN ROOT
PERF6    CW,R2    R3
         BNE      PIK11
         LB,R3    *R4,R1            X
         OR,R3    L(2)              X SET BITS 6+7 OF E TO 10
         STB,R3   *R4,R1            X
         B        SECT3
         PAGE
************************************************************************
*    PROCDEF      PROCEDURE DEFINITION ROUTINE
*
PROCDEF  AI,R2    2                 X
         LB,R3    0,R2              X GET CONTROL BYTE
         AI,R2    -2                X
         CI,R3    X'88'
         BNE      PARAT     BRANCH IF NOT SECTION DEFINITION
         SLS,R2   -1                X GET REF NO
         LH,R3    1,R2              X
         STW,R3   PRESEC        SAVE REF NO TO RESOLVE POSSIBLE QUALIF
         LB,R6    *ADINDEX,R3       X
         AI,R3    1                 X
         LB,R7    *ADINDEX,R3       X
         SLS,R7   24                X
         SLD,R6   8                 X GET DINDEX ENTRY
         AI,R3    1                 X
         LB,R7    *ADINDEX,R3       X
         SLS,R7   24                X
         SLD,R6   8                 X
         BAL,11   CHAIN       GET PDD ADDRESS
         XW,R3    R4
         LI,R3    9                 X
         LB,R3    *R4,R3            X STORE PRIORITY IN LSTPRIOR
         STW,R3   LSTPRIOR          X
         LW,R3    INIT              HAS START LOCATION OCCURRED YET?
         BNEZ     PARAS             YES
         LW,R3    DECLAR            ARE WE IN DECLARATIVES?
         BNEZ     PARAS             YES
         LI,R3    2                 PUT PDN AND PRIORITY NO.
         LW,R3    *R4,R3             OF PROGRAM START SECTION
         AND,R3   L(X'00FFFFFF')      INTO
         STS,R3   PDBP+1               PDB
         STW,R3   INIT              SET FLAG - THIS IS PROGRAM START
         B        PARAS
PARAT    CI,R3    X'89'
         BNE      SECT3      EXIT IF NOT PARA DEFINITION
         BAL,11   RESOLV
         BNE      SECT3             UNDEFINED                           COBOL22
PARAS    LB,R3    *R4               X
         OR,R3    DECLAR            X BUMP FIELD A IF IN DECLARATIVES
         STB,R3   *R4               X
         B        SECT3
         PAGE
************************************************************************
*    RESOLV       RESOLV POSSIBLE QUALIFIED PROC NAME
*
*    INPUT        BA OF INPUT IN R2
*    LEAVES    MAIN REF NO. IN R4 AND QUAL. REF NO. IN R5
*
*    CONDITITION CODE IS = IF DEFINED NOT = OTHERWISE
*
RESOLV   SLS,R2   -1                R2 = HA OF INPUT
         LH,R4    1,R2              R4 = REF NO
         LW,R5    PRESEC     LOAD REF NO OF DEFAULT QUALIFIER
         STW,11   ADD2
         BAL,11   GETEPF            GET POSSIBLE QUALIFIER
         AI,R2    2                 X
         LB,R3    0,R2              X IF IT IS A QUALIFIER
         CI,R3    X'85'             X GO TO QD
         BE       QD                X
         STW,R2   PASWT             OTHERWISE SET BACK INPUT
         B        RESOLVT+1
QD       SLS,R2   -1                X
         AI,R2    1                 X LOAD REF NO OF QUALIFIER
         LH,R5    0,R2              X
         B        RESOLVT+1
         PAGE
************************************************************************
*    RESOLVT      CONVERT REF NO TO PDD ENTRY LOCATION
*
*    INPUT      MAIN REF NO. IN R4
*               QUALIFIER REF NO. IN R5
*    OUTPUT     ADDRESS OF PDD ENTRY IN R4
*
*    CONDITITION CODE IS = IF DEFINED NOT = OTHERWISE
*
RESOLVT  STW,11   ADD2              SAVE RETURN ADDRESS
         LB,R6    *ADINDEX,R4     X
         AI,R4    1               X
         LB,R7    *ADINDEX,R4     X
         SLS,R7   24              X GET DINDEX ENTRY CORRESPONDING
         SLD,R6   8               X TO REF NO
         AI,R4    1               X
         LB,R7    *ADINDEX,R4     X
         SLS,R7   24              X
         SLD,R6   8               X
         BAL,11   CHAIN
         BNE      *ADD2          RETURN NO IF UNDEFINED
         STW,R3   R4             SAVE LOCATION
         LW,R6    L(X'00FFFFFF')  X
         AND,R6   0,R3            X GET SYNONYM LINKAGE
         BAL,11   CHAIN
         BE       RESOLV2
         LCI      0                X
         B        *ADD2            X RETURN YES
RESOLV2  LB,R6    *ADINDEX,R5      X
         AI,R5    1                X
         LB,R7    *ADINDEX,R5      X
         SLS,R7   24               X GET DINDEX ENTRY FOR QUALIFIER
         SLD,R6   8                X
         AI,R5    1                X
         LB,R7    *ADINDEX,R5      X
         SLS,R7   24               X
         SLD,R6   8                X
         BAL,11   CHAIN
         BNE      *ADD2       QUALIFIER NOT DEFINED
         XW,R2    R3
         STW,R2   LIM1             X
RLOOP    LI,R3    16               X
         LB,R3    *R2,R3           X
         AI,R3    20               X
         SLS,R3   -2               X
         AW,R2    R3               X  CALC + STORE SCOPE OF QUALIFIER
         LB,R3    *R2              X
         CI,R3    X'96'            X
         BE       RLOOP            X
         CI,R3    X'97'            X
         BE       RLOOP            X
         STW,R2   LIM2             X
         CW,R4    LIM1                X
         BL       NOTQUAL             X
         CW,R4    LIM2                X EXIT YES IF FIRST TRY WAS OK
         BG       NOTQUAL             X
         LCI      0                   X
         B        *ADD2               X
NOTQUAL  STW,R4   R2               X
         LW,R6    L(X'00FFFFFF')   X
         AND,R6   *R2              X
         BAL,11   CHAIN            X
         BE       POSS             X
         LCI      0                X  RESOLVE QUALIFICATION
         B        *ADD2            X
POSS     STW,R3   R2               X
         CW,R3    LIM1             X
         BL       NOTQUAL+1        X
         CW,R3    LIM2             X
         BG       NOTQUAL+1        X
         STW,R3   R4               X
         LCI      0                X
         B        *ADD2            X
         PAGE
************************************************************************
*    SRT          PROCESS SORT STATEMENT
*
SRT      BAL,11   GETEPF       BYPASS A CLUSTER
         AI,R2    1
         LB,R3    0,R2       GET CONTROL BYTE
         AI,R2    -1
         CI,R3    X'68'
         BNE      SECT3S           EXIT IF NOT SORT
         AI,R2    3
         LB,R3    0,R2        GET STATEMENT OPTIONS
         AI,R2    -3
         CI,R3    X'08'
         BE       INS              IF INPUT PROCEDURE
         CI,R3    X'20'
         BNE      SRT              IF NOT OUTPUT PROCEDURE
         BAL,11   RESOLV
         BNE      SENDA
         LI,R3    8                X
         LB,R2    *R4,R3           X SET BIT 4 OF PROC REF BYTE
         OR,R2    L(X'08')         X
         STB,R2   *R4,R3           X
         STW,R4   PROSAV       SIDR 3640 03/09/71                       COBOL22
         MTB,1    PROSAV       * FLAG FOR OUTPUT RANGE                  COBOL22
SEND     BAL,11   GETEPF            X
         AI,R2    1                 X
         LB,R3    0,R2              X
         AI,R2    -1                X
         CI,R3    X'68'             X
         BNE      NOTHRU            X TEST FOR THRU OPTION
         AI,R2    3                 X
         LB,R3    0,R2              X
         AI,R2    -3                X
         CI,R3    X'01'             X
         BNE      NOTHRU            X
         BAL,11   RESOLV
         BNE      SRT
         LI,R3    8         X
         LB,R2    *R4,R3    X
         OR,R2    L(X'04')  X SET BIT 5 OF PROC REF BYTE
         STB,R2   *R4,R3    X
         BAL,11   XSET        SET UP AN EXIT NO.
         XW,R4    PROSAV       SIDR 3640 03/09/71                       COBOL22
         BE       SRT          * NULL START OF RANGE                    COBOL22
         LB,R2    R4           * FLAG FOR OUTPUT RANGE                  COBOL22
         STB,R2   PROSAV       * FOR COMPARE                            COBOL22
SRTSCN   AI,R4    4            * POINT AT NAME                          COBOL22
         LB,R3    *R4          * BYTE SIZE OF NAME                      COBOL22
         AI,R3    4            * FOR ROUNDING                           COBOL22
         SLS,R3   -2           * WORD SIZE OF NAME                      COBOL22
         AW,R4    R3           * NEXT SEC/PAR                           COBOL22
         CW,R4    PROSAV       * TEST FOR END RANGE                     COBOL22
         BGE      SRT          * FINISHED                               COBOL22
         LI,R3    8            * INDEX TO REF BYTE                      COBOL22
         LB,R2    *R4,R3       * REF BYTE                               COBOL22
         MTB,0    PROSAV       * TEST OUTPUT FLAG                       COBOL22
         BE       %+3          * INPUT                                  COBOL22
         OR,R2    L(X'08')     * SET BIT 4 ON                           COBOL22
         B        %+2          *                                        COBOL22
         OR,R2    L(X'10')     * SET BIT 3 ON                           COBOL22
         STB,R2   *R4,R3       * NEW REF BYTE                           COBOL22
         B        SRTSCN       * LOOP                                   COBOL22
NOTHRU   RES      0
         LW,R4    PROSAV       SIDR 3640 03/09/71                       COBOL22
         BEZ      SRT+1
         LI,R3    8         X
         LB,R5    *R4,R3    X SET BIT 5 OF PROC REF BYTE
         OR,R5    L(X'04')  X
         STB,R5   *R4,R3    X
         BAL,11   XSET           SET UP AN EXIT NO.
         B        SRT+1
*   INS IS ENTERED IF AN INPUT PROCEDURE IS SENSED
INS      BAL,11   RESOLV
         BNE      SENDA
         LI,R3    8         X
         LB,R2    *R4,R3    X
         OR,R2    L(X'10')  X SET BIT 3 OF PROC REF BYTE
         STB,R2   *R4,R3    X
         STW,R4   PROSAV       SIDR 3640 03/09/71                       COBOL22
         B        SEND
SENDA    LI,15    0          = P1 IS UNDEFINED
         STW,15   PROSAV       SIDR 3640 03/09/71                       COBOL22
         B        SEND
         PAGE
************************************************************************
*    UZ           PROCESS USE
*
*    NOTE    ON ENTRY TO UZ,  R4 ALREADY CONTAINS THE PDD ADRRESS OF
*        THE LAST SECTION READ FROM EPF
*
UZ       EQU      PERF4
         PAGE
***********************************************************************
*    XSET         SET UP AN EXIT NO. IN PDD IF THERE IS NONE
*
*        INPUT     ADDRESS OF PDD ENTRY IN R4
*
XSET     LI,R1    7
         LH,R3    *R4,R1         GET EXIT NO. FIELD FROM PDD ENTRY
         BNEZ     *11        EXIT IF THERE ALREADY IS ONE
         LI,R3    1
         MTH,4    PDBS,R3           INCREMENT BASE 5 LOCATION COUNTER
         LH,R3    PDBS,R3           DERIVE
         SLS,R3   -2                 EXIT NO.
         STH,R3   *R4,R1      STORE IN PDD ENTRY
         B        *11
         PAGE
***********************************************************************
*    SECT4        WRAP UP PHASE 2.2 OUTPUT PDD
*
SECT4    RES      0
         LW,R7    SITAD
         SLS,R7   1                 R7 = HA OF SIT
OPDDL    LH,R4    0,R7
         CI,R4    -1
         BE       PH22E      EXIT IF END OF SIT
         AND,R4   L(X'FFFF')
         AI,R7    1          R7 = HA OF SIT + 1
         LH,R5    0,R7
         SLS,R5   16
         SLD,R4   -2         (R4) = LENGTH OF SEGMENT IN WORDS
         STW,R4   R2
         LI,R4    0
         SLD,R4   18
         AI,R7    1         R7 = HA OF SIT + 2
         LH,R5    0,R7
         AI,R7    1          R7 = HA OF NEXT SIT ENTRY
         SLS,R5   16
         SLD,R4   -8       R4 = SEG. NO. , R5 = LOC.
         SLS,R4   14
         OR,R4    R2
         STW,R4   12          SAVE CTL DATA IN DECA
         SLS,R2   2          R2 = LENGTH OF SEGMENT IN BYTES
         LI,R4    0
         SLD,R4   26          R4 = BA SEGMENT LOCATION
         BAL,11   WRPDD       OUTPUT SEGMENT
         LI,R2    4
         LI,R4    48
         BAL,11   WRPDD        OUTPUT CONTROL BLOCK     FROM DECA
         B        OPDDL
         PAGE
***********************************************************************
*    OPPS         ABORT IF NOT ENOUGH CORE
*
OPPS     RES      0                 ISSUE FATAL DIAGNOSTIC -
         LI,1     122               COMPILER LIMITATION EXCEEDED -
         BAL,11   DIAG              COMPILATION ABORTED
         B        PH22E             EXIT FROM 2.2
*******************************************************************E****
*    PDD BUFFER AREA
*
PDDBUF   RES      0
         RES      BUFAREA
PDDEND   DATA     PDDEND
*
         END
