         SYSTEM   SIG7FDP
         TITLE    '******* COBOL 15 *******'
COB15    LI,7     X'800'
         STW,7    MASK
         LI,10    RET1
         STW,10   RETURN1
         LI,1     1
         LI,15    0
         AND,7    PDBP              IF EDF IS PROCESSED GO TO
         BEZ       EPF                  PROCESS EPF
         LI,10    RET2
READ1    BAL,11   RDEDF
         BLZ      EOF1
         STW,2    4
         AI,2     2
         LB,6     0,2
         SLS,6    -4
         CI,6     9                 DOES OPERAND = 9
*                                      SIDR 1954
*                                      ILLEGAL TRAP IN 31 DUE TO
*                                      DICTIONARY OVERFLOW AND USE OF
*                                      X'1A' AND X'36' FOR LINE-COUNTER
*                                      AND PAGE-COUNTER IN 1.3(DBDE73)
*
         BE        READ19
         LW,6      4                   BA(CLUSTER)
         LW,7      TESTLC              LINE COUNTER TEST
         CBS,6     0
         BE        READ19              TREAT LIKE 9
         LW,6      4
         LW,7      TESTPC              PAGE COUNTER
         CBS,6     0
         BE        READ19
         B         RET2                OUTPUT EDF AS IS
TESTLC   GEN,8,24  19,BA(TEST36)
TESTPC   GEN,8,24  19,BA(TEST1A)
TEST36   DATA      X'0C218001'
         GEN,24,8  X'00360C','L'
         TEXT      'INE-COUNTER '
TEST1A   DATA      X'0C218001'
         GEN,24,8  X'001A0C','P'
         TEXT      'AGE-COUNTER '
READ19   EQU       %
*                                      END OF SIDR 1954
         LB,6     0,4
         CI,6     4                 LENGTH LESS THAN 4 (NOT A NAME)
         BL       RET2              YES - OUTPUT EDF
         AI,2     -1
         LB,6     0,2
         CI,6     X'2A'             CONTROL = 2A (PICTURE)
         BE       RET2              YES - OUTPUT EDF
         LB,5     0,4
         LW,6     4
         LI,7     BA(STOR)
         STB,5    7
         MBS,6    0                 1ST HALF OF CLUSTER TO STORAGE
         STB,5    7
         MBS,6    0                 2ND HALF OF CLUSTER TO STORAGE
         LI,2     STOR
         LI,3     HA(STOR)
         LI,4     BA(STOR)
         LI,11    FREN              SET RETURN ADDRESS
         B        NORMAL
RET1     BAL,11    SHIFT            DELETE NAME
RET2     BAL,11   WREDFS            OUTPUT EDF
         B        READ1
EOF1     LI,7     X'400'
         AND,7    PDBP
         BEZ      EOF2              IF EPF IS RESOLVED
         CW,15    FLAG
         BNE      EPF               PROCESS EPF IF DNT OVERFLOW
         LI,6     0
         LI,7     X'800'
         STS,6    PDBP              INDICATE EDF RESOLVED
*           PROCESS EPF
EPF      LI,10    RET3              INITIALIZE
         STW,10    RETURN1
         LI,10    RET4
         STW,15   FLAG
         LI,7     X'400'
         STW,7    MASK
READ2    BAL,11   RDEPF
         BLZ      EOF2              IF EOF
         LB,5     0,2
         LW,6     2
         LI,7     BA(STOR)          MBS TWICE FORPROG TRAILER CLUSTER
         STB,5    7
         MBS,6    0
         STB,5    7
         MBS,6    0
         LI,2     STOR
         LI,3     HA(STOR)
         LI,4     BA(STOR)
         LI,13    X'0000F000'       MASK FOR OPERAND
         CW,15    FLAG
         BNE      EQ9
         LB,6    *2,1               IS THIS SOURCE LINE CONTROL
         BNEZ     EQ8               NO
         LW,6     0,2
         STW,6    SPDAR             STORE LINE NUMBER IN SPD BUFFER
         LW,6     1,2
         STW,6    SPDAR+1           STORE COPIED LINE NUMB IN SPD BUFFER
         B        RET4              TO OUTPUT EPFS
EQ8      LI,12    X'00008000'
         CS,12    0,2               DOES OPERAND = 8?
         BE       REF9
EQ9      LI,12    X'00009000'
         CS,12    0,2               DOES OPERAND = 9?
         BE       TRAILER
         B        RET4              TO OUTPUT EPFS
RET3     LI,12    X'F00'
         AND,12   0,2
         CI,12    X'400'            PROCEDURE NAME - DO NOT DELETE NAME
         BE       RET4
         CI,12    X'600'            PARAMETER NAME - DO NOT DELETE NAME
         BE       RET4
         CI,12    X'900'            PARAGRAPH DEFINITION  REF = 9
         BNE      %+5
         BAL,11   TESTOV            OMIT SPD OUTPUT IF DNT OVERFLOW
SET96    LI,6     X'96'             SET SPD CONTROL TO 96 (PARAGRAPH)
         STB,6    SPDAR,1
         B        OUTSPD
         CI,12    X'800'               REF = 8 (SECTION DEFINITION)
         BE       SET94-1
         CI,12     X'A00'           REF = A (SECTION TRAILER)
         BNE      SHIFT-1           NO - GO TO DELETE NAME
         LI,6     6                 IF REF = A DELETE NAME BY
         STB,6     0,4                   CHANGING CLUSTER LENGTH
         B      RET4
         BAL,11   TESTOV            OMIT SPD OUTPUT IF DNT OVERFLOW
SET94    LI,6     X'94'             SET SPD CONTROL TO 94 (SECTION)
         STB,6    SPDAR,1
OUTSPD   LH,12    1,3
         STH,12     SPDAR+1,1       STORE REF NUMBER
         LW,12    0,2
         STB,12    SPDAR+2          STORE PRIORITY NUMBER
         STB,5    SPDAR+2,1         STORE NO. BYTES  IN NAME
         LI,6       BA(STRING)
         LI,7      BA(SPDAR+2)+2
         STB,5    7
         MBS,6    0                 MOVE PROCEDURE NAME
         AI,5     12                GET LENGTH
         SLS,5    -1
         STB,5    SPDAR             STORE CLUSTER LENGTH
         STW,4    SAVE4
         LI,4     BA(SPDAR)
         BAL,11   WRSPD             OUTPUT SPD
         LW,4     SAVE4
RET4     BAL,11   WREPFS            OUTPUT EPFS
         B        READ2
*
*    DELETE NAME AND CHANGE CLUSTER LENGTH
*
         LI,11     RET4             SET RETURN ADDRESS
SHIFT    LW,6     5                 GET NAME LENGTH
         AI,6     1
         SLS,6    -1
         LB,8     0,4               GET CLUSTER LENGTH
         SW,8     6                 SUBTRACT NAME LENGTH
         STB,8    0,4               NEW CLUSTER LENGTH
         AW,8     8                 BYTE ADDRESS
         AI,8     -6                BYTE STRING LENGTH
         LW,6     4
         AI,6     6
         STW,6    7                 DEST ADDRESS
         AW,6     5                 SOURCE ADDRESS
         STB,8    7                 LENGTH
         MBS,6    1                 EXTRACT NAME & BYTE COUNT (J&K)
         B       *11
*
*      MOVE NAME TO 'STRING'  (ADD 1 TO SOURCE ADDRESS FOR TRAILER)
TRAILER  LI,11    FREN
         LI,6     2
         LB,5    *2,6
         CI,5     X'9A'
         BNE      NORMAL            NOT SECTION TRAILER
         LI,7     10
         LW,6     4
         AI,6     4                 BA OF BUF & 1 WORD
         B        MOVES
NORMAL   LI,7     6
         LW,6     4
MOVES    LB,5    *2,7               LENGTH OF STRING IN R5
         LI,7     BA(STRING)
         STB,5    7
         MBS,6    7                 MOVE NAME TO 'STRING'
         B       *11
*
*     FIND REFERENCE NUMBER
FREN     RES      0                 FIND REFERENCE NUMBER ROUTINE
         LH,6     1,3               HASH NUMBER
         AI,6     HA(DNTHIDX)       LOCATE INITIAL LINKAGE IN HASH TABLE
         B        NOLINK
LINKAGE  LI,6     HA(DNT)
         AW,6     12               INDEX IN DNTINDX
         CH,5     1,6               COMPARE NO BYTES IN STRING
         BE       COMPAREB
NOLINK   LH,12    0,6              LINKAGE NUMBER
         BNEZ     LINKAGE
         CW,15    FLAG
         BNE      *10
         LW,7     DNTPNTR
         AI,7     HA(DNT)
         CI,7     HA(ENDTAB)-22     CHECK FOR DNT OVERFLOW
         BLE      HASHOK
         STW,1    FLAG              INDICATE DNT OVERFLOW
         B        *10
HASHOK   LW,8     DNTPNTR
         STH,8    0,6               SET LINK
         LW,8     5
         AI,8     1
         SLS,8    -1
         AI,8     3                 SUM OF LINK,REF NR, BYTE LENGTH,NAME
         AWM,8    DNTPNTR           UPDATE DNT POINTER
         LH,8     PDBL              LAST USED REFERENCE-NUMBER
         AI,8     3                 INCREMENT BY 3
         STH,8    1,3               STORE REF NUMB IN CLUSTER
         LW,6     7
         AI,6     1
         STH,8    0,6               NEW ENTRY REFERENCE NUMBER
         STH,8    PDBL              UPDATE REFERENCE NUMBER
         STH,15   0,7               NEW ZERO LINK
         STH,5    1,7               LENGTH NEW BYTE ADDRESS
         AW,7     7                 BYTE ADDRESS
         AI,7     6                 POINTS TO HW(4) OF ENTRY
         STB,5    7                 COUNT IN BYTES TO MOVE
         LI,6     BA(STRING)
         MBS,6    0
         LI,14    X'2006'
         AND,14   PDBCC
         BCR,3    RETURN            NO - EXIT
*
*   BUILD AND OUTPUT XRF NAME CLUSTER
         STW,8    XRFCL             REFERENCE NUMBER
         LI,6     BA(STRING)        PREPARE
         LI,7     BA(XRFCL)+5        NAME-STRING
         STB,5    XRFCL+1             AND
         STB,5    7                    LENGTH-COUNT
         STW,5    8
         MBS,6    0                 MOVE NAME TO CLUSTER AREA
         AI,8     7                  COMPUTE
         SLS,8    -1
         STB,8    XRFCL               HW LENGTH OF CLUSTER
         STW,4    SAVE4
         LI,4     BA(XRFCL)
         BAL,11   WRXRF             OUTPUT XRF CLUSTER
         LW,4     SAVE4             RESTORE R4
         B        RETURN
COMPAREB LW,9     6
         AW,9     6                 FORM THE
         AI,9     6                   BYTE ADDRESS
         STB,5    9                    OF NAME-STRING
         LI,8     BA(STRING)
         CBS,8    0                 COMPARE THE STRINGS
         BNE      NOLINK            UNEQUAL - GO TO FOLLOW THE CHAIN
FOUND    AI,6     1
         LH,7     0,6
         STH,7    1,3               STORE REFERENCE NUMBER
RETURN   LI,6     X'00008000'       SET OPERAND TO 8
         LI,7     X'0000F000'
         STS,6    0,2
         B        *RETURN1
*
*    EOF ROUTINE FOR EPF (ALSO EDF IF EPF IS RESOLVED)
EOF2     CW,15    FLAG
         BNE      INITIAL           IF DNT OVERFLOW
         LI,6     0
         LW,7     MASK
         STS,6    PDBP              INDICATE FILE RESOLVED
         LI,7     X'C00'
         AND,7    PDBP
         BEZ      PH15E             DONE - BOTH RESOLVED
*
*     INITIALIZE DNT INDEX AREA
*
INITIAL  RES      0
         LI,2     33                LOOP COUNTER
         LI,1     0
ZLOOP    STD,15   DNTHIDX,1         ZERO DNTINDEX AREA,FLAG
         AI,1     1
         BDR,2    ZLOOP
         LI,6     7
         STW,6    DNTPNTR           RESET DNT POINTER
         B        PH15E             GO OUT   RETURN
*
*    PREPARE RESOLVED CLUSTERS (OPERAND 8) FOR SPD OUTPUT
*
REF9     LI,13    X'F00'
         LS,12    0,2
         CI,12    X'8900'
         BNE      %+3
         BAL,11   NORMAL            MOVE NAME TO 'STRING'
         B        SET96             IF REF = 9 (PARAGRAPH)
         CI,12    X'8800'
         BNE      RET4
         BAL,11    NORMAL
         B        SET94             IF REF = 8 (SECTION)
*
*   CHECK DNT OVERFLOW
TESTOV   CW,15    FLAG
         BNE      RET4
         B       *11
STRING   RES      10                STORAGE FOR NAME
RETURN1  DATA     0                 INDIRECT RETURN FROM FREN
SPDAR    RES      12                SPD BUFFER
XRFCL    DATA     0                 XRF BUFFER
         RES      8
STOR     RES      105
DNTPNTR  DATA     7
DNT      RES      5000
ENDTAB   DATA     0
EPFSBUF  RES      105
EDFSBUF  RES      75
         DEF      EPFSBUF,EDFSBUF
         BOUND    8
DNTHIDX  RES      0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0,0,0,0,0,0
         DATA     0,0,0,0,0
FLAG     DATA     0                 DNT OVERFLOW SWITCH
MASK     DATA     0
SAVE4    DATA     0
         REF      RDEDF,WREDFS,RDEPF,WREPFS,WRXRF
         REF      PDBCC,PDBL,PH15E,PDBP
         REF      WRSPD
         DEF      COB15
         END      COB15
