         SYSTEM   SIG7FDP
*
*COB51   PHASE 5.1  PROCESSING
*
         DEF      COB51
         REF      END51
         REF      INLTAB
         REF      PRLTAB
         REF       RDPOF
         REF      PDBXA,CARDNO
PDBX     EQU      PDBXA
         REF      DIAG
         REF      PDB
         REF      PDBU
         REF      PDBV
         REF      PDBQ
         REF      PDBY
         REF      PDBZ
         REF      DECLTB
         REF      GENORG,OD2,OD3
         REF      DECLXD,DECLXR,DECLN
         REF      OBFOUT,CHEKSM,EMPSZ,BUFBEG
         REF      BUFVAR,RECNT,OBJFB1,OBJFB2
         REF      OBJCSZ,ENDOUT
         REF      LABDCL,LABNAM
         REF      WRILF
         REF      LCB
         REF      PDBJ                                                  COBOL51
         REF      ILFMAX                                                COBOL51
PDBVA     EQU     PDBV
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
LR       EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
         TITLE    '*** INITIALIZATION ***'
         PAGE
*
* INITIALIZE  CONSTANTS  AND  TABLES
*
COB51    RES      0
         LI,R8    0
         STW,R8   NEWADR            START ADDR FOR COMMON VALUES
         STW,R8   PARGT             INITIAL PARAGRAPH FLAG
         STW,R8   *INLTAB           INT. LABEL CONTROL WORD
         STW,R8   DECLN             DECLARATION NO.
         STW,R8   SEGN
         STW,R8   SEGMN
         STW,R8   CHEKSM
         STW,R8   LCB
         LI,R8    -1
         STW,R8   RECNT             RECORD COUNT
         LI,R2    BA(OBJFB1)        INITIALIZE OBJ. FILE
         STW,R2   BUFBEG            BUFFER (BEGIN ADDR.)
         AI,R2    4
         STW,R2   BUFVAR            DATA AREA (BEGIN ADDR)
         LI,R8    104
         STW,R8   EMPSZ             STORAGE SPACE IN OBJ. FILE BUFFR
         LW,R8    =X'3C00006C'      REC TYPE,MODE,FORMAT,SEQ,CHEKSM,SIZE
         STW,R8   OBJFB1
         STW,R8   OBJFB2
         LI,R1    0                 ALL OBJ.FILE OUTPUT TO ROOT SEG MOD
* INITIALIZE LOCATION COUNTER
         LI,R2    3                 GET BASE 1 (WORKING-STORAGE)
         LB,R8    PDBVA,R2              OVERFLOW
         SLS,R8   14                    IN WORDS
         STW,R8   LOCNTR              STORE IN LOCATION COUNTER
         LI,R2    0                 INITIALIZE INDEX
INL      LH,R8    PDBQ,R2           GET SIZE ,BYTES, OF VARIOUS
         AND,R8   =X'FFFF'          DATA AREAS (BASES 0-7)
         AI,R8    7                 ROUND TO D W SIZE
         SLS,R8   -3
         SLS,R8   1
         AWM,R8   LOCNTR            UPDATE LOC. COUNTER
         AI,R2    1
         CI,R2    5                 LOOK FOR BASE 4
         BE       INL2
         CI,R2    8
         BL       INL               DO FOR BASE NOS. 1-7
         B        COMS
INL2     STW,R8   DCBASE            SAVE ADDR. OF BASE 4
         B        INL
         TITLE    '*** COMMON STORAGE PROCESSING ***'
         PAGE
*
* COMMON STORAGE PROCESSING
COMS     RES      0
         LW,R8    PDBU              COMMON SIZE
         AND,R8   =X'FFFF'
         LI,R2    2                 GET BASE 9 (COMMON-STORAGE)
         LB,R2    PDBVA,R2              OVERFLOW
         SLS,R2    16              IN BYTES                             COBOL51
         AW,R8    R2                  ADD TO COMMON SIZE
         BEZ      GETPOF            NO COMMON DEFINED
         STW,R8   SAVSZ             SAVE SIZE (BYTES)
* DECLARE COMMON SECTION NAME
         LI,R2    BA(PDBY)          N,COMMON-NAME ADDR.
         BAL,LR   DECLXD            DECLARE EXTERNAL DEFINITION
* DECLARE DUMMY CONTROL SECTION FOR COMMON
         LW,R8    SAVSZ             SIZE OF COMMON (BYTES)
         LI,R9    1                 DECLARATION NO. OF COMM.-NAME
         BAL,LR   DUMMY
* SET ORG. OF COMMON TO ZERO
         LI,R12   0
         LI,R13   1                 COMMON BASE DECL NO.
         BAL,LR   GENORG
         B        GETPOF
SAVSZ    DATA     0
         TITLE    '*** OBTAIN POF CLUSTER ITEMS ***'
         PAGE
GETPOF   RES      0
         BAL,LR   RDPOF             OBTAIN POF CLUSTER, BYTE ADR IN R2
         AI,R2    1                 GET ADDR. OF CLUSTER CONTR. BYTE
         LB,R6    0,R2              GET CLUSTER CONTROL BYTE
         CI,R6    X'4F'
         BG       POFERR            UNKNOWN CONTROL BYTE
         EXU      JUMP,R6           BRANCH ON BYTE TYPE
JUMP     B        POFERR            UNKNOWN CONTROL BYTE
         B        LOCUP             1   INSTR. ITEMS, INCREMENT
         B        LOCUP             2   LOC. COUNTER ONLY
         B        LOCUP             3
         B        LOCUP             4
         B        LOCUP             5
         B        LOCUP             6
         B        LOCUP             7
         B        LOCUP             8
         B        LOCUP             9
         B        LOCUP             0A
         B        POFERR            0B
         B        POFERR            0C
         B        POFERR            0D
         B        LOCUP             0E
         B        LOCUP             0F
         B        LOCUP             10
         B        LOCUP             11
         B        LOCUP             12
         B        LOCUP             13
         B        LOCUP             14
         B        LOCUP             15
         B        LOCUP             16
         B        LOCUP             17
         B        LOCUP             18
         B        LOCUP             19
         B        LOCUP             1A
         DO       6
         B        POFERR            CONTROL BYTE ERROR
         FIN
         B        INVAPR            21   INITIAL VALUE
         B        GETPOF            22   ADDR. CONSTANTS, GET
         B        GETPOF            23   NEXT POF ITEM
         B        GETPOF            24
         B        GETPOF            25
         B        GETPOF            26
         B        GETPOF            27
         B        GETPOF            28
         B        GETPOF            29
         B        INVAPR            2A   INITIAL VALUE
         B        INVAPR            2B
         B        INVAPR            2C
         B        INVAPR            2D
         B        INVAPR            2E
         DO       18
         B        POFERR            CONTROL BYTE ERROR
         FIN
         B        INTLPR            41  INTERNL LABEL
         B        PRLPR1            42  PROCEDURE LABEL (SECTION)
         B        PROLPR            43  PROCEDURE LABEL (PARAGR)
         B        PRLPR1            44  ENTRY POINT (SECTION)
         B        PROLPR            45  ENTRY POINT (PARAGR)
         B        PRISPR            46  PRIORITY SEGMENT
         B        GETPOF            47  LINE COUNT
         B        POFERR            CONTROL BYTE ERROR
         B        POFERR
         B        POFERR            CONTROL BYTE ERROR
         B        POFERR            CONTROL BYTE ERROR
         B        POFERR            CONTROL BYTE ERROR
         B        POFERR            CONTROL BYTE ERROR
         B        POFERR            CONTROL BYTE ERROR
         B        ENDPR             4F  END OF POF
*
*    AN ILLEGAL POF CONTROL BYTE HAS BEEN ENCOUNTERED - ABORT
POFERR   RES      0
         LI,R1    514
         BAL,LR   DIAG              COMPILER ERROR 14
         B        GETPOF
         TITLE    '*** LOCATION COUNTER UPDATING ***'
         PAGE
*
* LOCUP,  UPDATE LOCATION COUNTER -LOCNTR- WITH 1 WORD,RETURN TO READ
* NEXT POF CLUSTER
*
LOCUP    RES      0
         MTW,1    LOCNTR            INCREMENT LOCATION COUNTER
         B        GETPOF            GET NEXT POF CLUSTER
LOCNTR   DATA     0                 LOCATION COUNTER (WORD COUNT)
         TITLE    '*** INITIAL VALUE PROCESSING ***'
         PAGE
*
* INITIAL VALUE PROCESSOR (COMMON-STORAGE ONLY IN PHASE 5.1)
*
INVAPR   RES      0
         AI,R2    1
         LB,R4    0,R2              OBTAIN BASE NO. OF VALUE ITEM
         CB,R4    BCOM              COMPARE WITH BASE NO. FOR COMMON
         BNE      GETPOF            NO COMMON
         STW,R2   SAV2
         LI,R12   0
         STW,R12  BYTRM             INITIALIZE BYTE REM. COUNTER
         LI,R3    48                BYTE ADDR OF R12
         AW,R3    =X'03000001'      CLUSTER ITEM TO R12 (BYTES 1,2,3)
         MBS,R2   1                 MOVE TO R12 (SOURCE OFFSET =1)
         CW,R12   NEWADR            COMP. GIVEN ORG. WITH COMPUTED ORG.
         BE       INV1              NO NEW ORIGIN NEEDED
         STW,R12  NEWADR            USE GIVEN ORG. AS NEW ONE
* HOLE IN COMMON STORAGE, GENERATE NEW OBJ. CODE ORIGIN DECLARATION
         LB,R13   CDECL             DECLARATION SEQ. NO. OF COMMON
         STB,R6   SAV1
         BAL,LR   GENORG            GENERATE ORG. ITEM
         LB,R6    SAV1
* OBTAIN SIZE OF INITIAL VALUE
INV1     RES      0
         LB,R2    LCBL,R6           GET NEW CONTROL BYTE
         STW,R2   LCBL              SAVE FOR LISTING OUTPUT
         LW,R2    SAV2              RESTORE ADDR. OF BASE NO. IN CLUSTER
         LI,R3    4                 BYTE COUNT (1 WORD)
         CI,R6    X'2B'             TEST CONTR. BYTE
         BL       INV2              21,2A BIN,FL PNT (1 WORD)
         BG       INV11             2C,2D,2E DEC., DISPLAY (N BYTES)
         LI,R3    8                 BYTE COUNT (2 WORD)
INV2     AI,R2    3                 GET ADDR OF VALUE FIELD -1
INV3     LI,R8    X'40'             LOAD ABSOLUTE CONTR BYTE
         AW,R8    R3                ADD LENGTH OF ITEM (BYTES)
INV4     AWM,R3   NEWADR            ADDR FOR NEXT ENTRY
         AI,R3    1                 INCREM. SIZE FOR CONTROL BYTE
INV5     STB,R8   0,R2              STORE CONTR. BYTE
         LW,R15   LCBL              GET PROPER INITIAL VALUE
         STW,R15  LCB               CONTROL BYTE FOR LISTING
         BAL,LR   OBFOUT            OUTPUT VALUE TO OBJ. FILE BUFFR
         LW,R3    BYTRM             BYTE COUNT
         BEZ      GETPOF            NO BYTES LEFT
         LW,R2    BAD               BYTE ADDR OF PREV STRING
         AI,R2    16                NEXT ADDR FOR BYTE STRING SOURCE
         B        INV13
INV11    AI,R2    4                 GET ADDR OF LENGTH FIELD
         LB,R3    0,R2              GET LENGTH OF VALUE
INV13    CI,R3    16
         BGEZ     INV15             PROCESS 16 BYTES
         LI,R8    0                  LESS, SET BYTES REMAINING TO ZERO
         STW,R8   BYTRM
         B        INV3
INV15    AI,R3    -16
         STW,R3   BYTRM             SAVE NO. OF BYTES REMAINING
         LI,R3    16
         LI,R8    X'40'
         STW,R2   BAD
         B        INV4
BCOM     DATA,1   9                 COMMON BASE NO. = 9
         DATA,3   0
CDECL    DATA,1   1                 DECLARATION NO. OF COMMON NAME
         DATA,3   0
NEWADR   DATA     0                 ORIGIN BYTE ADDR. FOR COMMON VALUES
BYTRM    DATA     0                 NO. OF BYTES REMAINING IN POF
BAD      DATA     0                 BYTE ADDR OF STRING IN POF ITEM
SAV1     DATA     0
SAV2     DATA     0                 SAVE R2
LCBL     RES      8
         DATA     X'00C20000'       CONTROL BYTES FOR
         DATA     0                 INITIAL VALUES
         DATA     X'0000C4C5'       TO LISTING FILE
         DATA     X'C6C7C800'
         TITLE    '*** INTERNAL LABEL DECLARATIONS ***'
         PAGE
*
* INTLPR INTERNAL LABEL PROCESSOR (R2=BYTE ADDR. OF POF CLUSTER)
*
INTLPR   RES      0
         AI,R2    2                 GET ADDR. OF LABEL NO.
         SLS,R2   -1                GET 1/2 WORD ADDR
         LH,R3    0,R2              PICK UP LABEL NO.
         BLE      GETPOF                  NO LABEL
         LW,R8    LOCNTR            PICK UP CONTENTS OF LOCATION COUNTER
         STW,R8   *INLTAB,R3        STORE IN INT. LABEL TABLE
         CW,R3    *INLTAB           UPDATE                              COBOL51
         BLE      %+2               CONTROL                             COBOL51
         STW,R3   *INLTAB           WORD                                COBOL51
         B        GETPOF            GET NEXT POF ITEM
         TITLE    '*** PROCEDURE LABEL DECLARATIONS ***'
         PAGE
*
*PROLPR, PROCEDURE LABEL PROCESSING (PARAGRAPH, SECTION PROCESSING)
*
PROLPR   RES      0
         LW,R8    PARGT             TEST PARAGRAPH FLAG
         BEZ      PR1               =0, FIRST DECLARATION IN MODULE
         STW,R2   SV2               SUBSEQ DECLARATION
************  OUTPUT INLTAB TO ILF  **********************************
         LW,R2    *INLTAB           NO. OF ENTRIES
         AI,R2    1                 +1 FOR COUNT WORD
         SLS,R2   2                 BYTE VALUE
         LW,R4    INLTAB            ADDR OF TABLE
         SLS,R4   2                 B.A.
         BAL,LR   WRILFX                                                COBOL51
         LI,R8    0                 SET INLTAB CONTROL
         STW,R8   *INLTAB           WORD TO ZERO
         LW,R2    SV2
PRLPR1   RES      0
         AI,R2    2
         SLS,R2   -1                1/2 WORD ADDR OF LABEL NO.
         LH,R3    0,R2              GET LABEL NO.
         LW,R8    LOCNTR            STORE LOCATION COUNTER VALUE
         OR,R8    SEGMN             ADD SEGMENT NO.
         STW,R8   *PRLTAB,R3        IN PROCEDURE LABEL TABLE
         B        GETPOF            GET NEXT POF ITEM
PR1      STW,R2   PARGT             SET 'NOT FIRST PARAGR.' FLAG
         B        PRLPR1
PARGT    DATA     0
SV2      DATA     0
WRILFX   RES      0                                                     COBOL51
         CW,R2    ILFMAX            SAVE MAX ILF SIZE                   COBOL51
         BLE      WRILF                                                 COBOL51
         STW,R2   ILFMAX                                                COBOL51
         B        WRILF             THEN WRITE IT                       COBOL51
         TITLE    '*** PRIORITY SEGMENT DECLARATIONS ***'
         PAGE
*
*PRISPR, PRIORITY SEGMENT DECLARATION
*
PRISPR   RES      0
* SAVE OBJ. CODE SIZE OF PREV. SEGMENT
         LW,R8    LOCNTR            SET LOC. COUNTER
         AI,R8    1                 VALUE TO DOUBLE WORD SIZE
         SLS,R8   -1
         SLS,R8   1
         LW,R2    SEGN
         STW,R8   OBJCSZ,R2         STORE IN OBJ. CODE SIZE TABLE
         AI,R2    1                 UPDATE
         STW,R2   SEGN              SEGMENT COUNTER
         LI,R3    0
         STB,R2   SEGMN,R3
         STW,R3   LOCNTR
         B        GETPOF
SEGN     DATA     0
SEGMN    DATA,1   0                 SEGM NO. BYTE
         DATA,3   0                 SPACER
         TITLE    '*** END OF POF ***'
         PAGE
*
* ENDPR  END OF POF PROCESSING
*
ENDPR    RES      0
         LW,R2    *INLTAB           NO. OF ENTRIES IN INLTAB
         AI,R2    1                 +1 FOR COUNT WORD
         SLS,R2   2                 BYTE SIZE OF RECORD
         LW,R4    INLTAB            TABLE ADDR.
         SLS,R4   2
         BAL,LR   WRILFX                                                COBOL51
         LW,R8    LOCNTR            LOCATION COUNTER VALUE
         AI,R8    1                 SET TO
         SLS,R8   -1                DOUBLE WORD
         SLS,R8   1                 VALUE
         LW,R2    SEGN              SEGMENT NO
         STW,R8   OBJCSZ,R2         STORE IN OBJ CODE SIZE TABLE
*
* CHECK FOR OUTPUT OF LABEL AREA DUMMY CONTROL SECTION
*
         LH,R8    PDBV              LABEL AREA SIZE
         AND,R8   =X'FFFF'
         BEZ      EN2               NO LABEL AREA
* DECLARE NAME OF D.C. SECTION
         LI,R2    BA(LABNAM)        ADDR OF LABEL AREA NAME
         BAL,LR   DECLXR
         LW,R9    DECLN             DECLAR. NO.
         STW,R9   LABDCL            FOR LABEL D.C. SECTN
         STW,R9   LABDCL+1                                              COBOL51
EN2      RES      0
         TITLE    '*** FILE PROCESSING ***'
         PAGE
*
* FILE PROCESSING, GENERATE AND OUTPUT DUMMY CONTROL SECTIONS
* FOR FILE RECORD AREAS, FILE INDEX AREAS, DCB AREAS.
*
         LW,R3    PDBZ+4
         AND,R3   =X'FF000000'      NO OF DB'S
         BEZ      ENDD              NONE
         LW,R4    PDBJ              CHECK CRS OPTION                    COBOL51
         AND,R4   =3
         BEZ      REP2-1            NO                                  COBOL51
         MTW,1    CRSF              SET FLAG                            COBOL51
         LI,R2    BA(DSI::)                                             COBOL51
         BAL,LR   DECLXD            DECLARE NAME DEF (EXTERNAL)         COBOL51
         LW,R9    DECLN             DECLARATION NO. OF NAME             COBOL51
         STW,R9   ISSECT            SAVE DECLARATION NO.                COBOL51
         LI,R8    204               BYTE SIZE DUMMY CTRL SECTION        COBOL51
         BAL,LR   DUMMY             DECLARE SECTION                     COBOL51
         LW,R12   NEWFL             GENERATE                            COBOL51
         LW,R13   ISSECT              ORIGIN                            COBOL51
         BAL,LR   GENORG                OF SORT  LINK AREA              COBOL51
         LI,R4    1
REP2     STW,R4   DDBC
         LH,R5    *PDBZ+4,R4        RELATIVE ADDR OF DDB
         CI,R5    -1                TEST FOR END OF DBINDX
         BE       ENDD              DOOMSDAY HAS ARRIVED
         AW,R5    PDBZ+3            ADDR OF DDB AREA
         STW,R5   DDBADB
         SLS,R5   -2                BA TO WA
         STW,R5   DDBADW
         SLS,R5   2                 BACK TO B.A.
* CHECK IF DB IS DDB OR NOT
         LB,R8    0,R5              DB A FIELD (ID)
         CI,R8    5
         BE       REPORT            RDB
         AND,R8   =X'7F'
         CI,R8    1
         BE       ISDDB             DDB
         CI,R8    2
         BE       ISDDB             SDB
         B        DC19              NEITHER
ISDDB    RES      0
* CHECK FOR SAME RECORD AREAS
         LI,R3    40
         LB,R4    *DDBADW,R3
         STW,R4   DDBN
         AI,R5    2                 GET 3RD BYTE IN DDB
         LB,R8    0,R5              SAME RECORD BYTE
         BEZ      REP20             NOT SAME TO OTHER FILES
*
* GO THRU ALL DDB,S IN CHAIN, SAVE LARGEST RECORD AREA,
* AND STORE DDB NO OF DECLARED DUMMY SECTN IN ALL DDB,S
*
         LW,R9    DDBN              DDB NO
         SLS,R9   2                 LINE UP WITH W FIELD IN DDB
         AI,R5    8                 B.A. OF REC. SIZE FIELD
         SLS,R5   -1                1/2 WORD ADDR
         BAL,LR   BLOCK
         STW,R8   BLOKSZ            USE FOR CURRENT DCB
         STW,R12  RECSZ             USE FOR CURRENT DCB
         AI,R12   3                 (ADJUSTED TO WORD BOUNDARY,
         AND,R12  L(X'FFFFFFFC')     IF NECESSARY)
         LW,R2    DDBADB                                     /SIDR-4311/COBOL51
         LB,R2    3,R2                                       /SIDR-4311/COBOL51
         BEZ      REP21%
         AI,R2    1
         AW,R12   R2                                         /SIDR-4311/COBOL51
         CI,R8    0
         BE       REP21%
         BAL,LR   DIAG224
         LI,R1    0
REP21%   RES      0                                                     COBOL51
         STW,R12  DUMSZ             = DUMMY CONTR. SECT. SIZE
         LB,R2    *DDBADW
         AND,R2   =X'80'            TEST BIT FOR CHAINS
         BNEZ     INDPR             NOT FIRST FILE IN CHAIN
REP5     SLS,R5   1                 GET BYTE ADDR
         AI,R5    -8                OF 'SAME' FIELD
         LB,R4    0,R5              DDB NO. OF NEXT DDB
         STW,R4   SV
         CW,R4    DDBN              COMPARE WITH FIRST DDB NO OF CHAIN
         BE       REP30             =, ALL DDB,S IN CHAIN CHECKED
         LW,R8    DECLN             GET DECLARATION NO OF
         AI,R8    1                 NEXT REC. AREA TO BE DECLARED
         SLS,R4   2                 DDB NO * 4
         AI,R4    1                 + 1 GIVES BYTE ADDR OF
         STB,R8   DECLTB,R4         ENTRY IN DECLAR. NO. TABLE
         LW,R4    SV
         LH,R5    *PDBZ+4,R4        RELATIVE ADDR OF DDB
         AW,R5    PDBZ+3            ADDR OF DDB AREA
         STW,R5   R2                SAVE DDBADB                         COBOL51
         LB,R8    0,R5              1ST BYTE IN DDB
         OR,R8    =X'80'            SET BIT FOR CHAIN FLAG
         STB,R8   0,R5              STORE BACK IN DDB
         AI,R5    6                 ADDR OF W FIELD (BYTE ADDR)
         STB,R9   0,R5              DDB. NO. OF 1ST DB IN CHAIN
         AI,R5    4                 BYTE ADDR OF REC. SIZE
         SLS,R5   -1                1/2 WORD ADDR
         BAL,LR   BLOCK             CHECK FOR BLOCKSIZE
         LB,R2    3,R2
         BEZ      REP21%%
         STW,R8   BLOKSZ
         AI,R2    1
         AW,R12   R2
         CI,R8    0
         BE       REP21%%
         BAL,LR   DIAG224
         LI,R1    0
REP21%%  RES      0                                                     COBOL51
         CW,R12   DUMSZ
         BLE      REP5
         STW,R12  DUMSZ
         B        REP5              LOOP FOR ALL DB,S IN SAME
REP20    AI,R5    8                 BYTE ADDR OF REC SIZE FIELD
         SLS,R5   -1                1/2 WORD ADDR
         BAL,LR   BLOCK
         STW,R8   BLOKSZ
         STW,R12  RECSZ
         AI,R12   3                 ADJUST TO
         AND,R12  L(X'FFFFFFFC')    WORD BOUNDARY
         LW,R2    DDBADB            IS THIS A
         LB,R2    3,R2               KEYED FILE?
         BEZ      REP25             NO
         CI,R8    0
         BE       REP21
         BAL,LR   DIAG224
         LI,R1    0
REP21    RES      0                                                     COBOL51
         AW,R12   R2                  KEY BUFFER TO THE
         AI,R12   1                    RECORD AREA
REP25    STW,R12  DUMSZ                 DUMMY SECTION
*
* DECLARE DUMMY CONTROL SECTION FOR FILE RECORD AREA
*
* DECLARE NAME
REP30    RES      0
         LW,R12   RECSZ             IF RECORD SIZE IS ZERO DON'T
         BEZ      INDPR              GENERATE A RECORD AREA
         LW,R2    DDBADB            BYTE ADDRESS OF DDB
         AI,R2    41                BYTE ADDR OF N,FILE-NAME IN DDB
         BAL,LR   DECLXD            DECLARE EXTERNAL NAME DEFINITION
         LW,R9    DECLN             DECLARATION NO. OF NAME
         STW,R9   DSECTM            SAVE DECLAR. NO. OF RECORD AREA
         LW,R4    DDBN
         SLS,R4   2
         AI,R4    1
         STB,R9   DECLTB,R4         TO DECLAR. TABLE
* DECLARE DUMMY SECTION
         LW,R8    DUMSZ             DUMMY CONTR SECT SIZE
         AI,R8    3                 ALL DSECTS SHOULD                   COBOL51
         AND,R8   =X'FFFFFFFC'       BE EVEN NUMBER OF WORDS            COBOL51
         BAL,LR   DUMMY             DECLARE SECTION
*
*                                                                       COBOL51
* C:LIO CHANGES OBVIATE THE NEED TO GENERATE A WORD WITH THE KEY LENGTH COBOL51
*                                                                       COBOL51
*
* GENERATE DUMMY CONTROL SECTION FOR FILE INDEX AREA
*
INDPR    RES      0
         LW,R2    DDBADB            BYTE ADDR OF DDB
         AI,R2    41
         LB,R8    0,R2              FILE NAME SIZE
         STW,R8   SRR8              SAVE
         AI,R2   -1                                                     COBOL51
         LI,R8    C'I'
         STB,R8   0,R2              I
         AI,R2    1
         LB,R9    0,R2              SAVE STRING LENGTH
         LI,R8    C':'              :
         STB,R8   0,R2
         AI,R2    -2
         AI,R9    2                 ADD 2 (FOR I:) TO LENGTH
         STB,R9   0,R2
         BAL,LR   DECLXD            DECLARE NAME
         LW,R9    DECLN             DECLARATION NO. OF NAME
         STW,R9   ISECTM            SAVE DECLARATION NO. OF INDEX AREA
         LW,R4    DDBN
         SLS,R4   2
         AI,R4    2
         STB,R9   DECLTB,R4         TO DECLAR. TABLE
         LW,R2    DDBADB
         AI,R2    37                BYTE ADDR OF 'NO INDEX WORDS'
         LB,R8    0,R2              SIZE OF DUMMY CONTR SECT
         SLS,R8   2                 CONVERT # WORDS TO BYTES
         BAL,LR   DUMMY             GENERATE SECTION
         LI,R12   0                 GENERATE
         LW,R13   ISECTM             ORIGIN OF
         BAL,LR   GENORG             INDEX-AREA
*        THE FOLLOWING FIXES CAUSE THE FILE NAME TO BE DEFINED          COBOL51
*        BEFORE IT IS REFERENCED.                                       COBOL51
*                                                                       COBOL51
         LW,R2    DDBADB            DDB BYTE ADDR                       COBOL51
         AI,R2    40                                                    COBOL51
         LI,R8    C'F'              INSERT F:IN FRONT                   COBOL51
         STB,8    0,R2              OF FILE NAME                        COBOL51
         AI,R2    1                                                     COBOL51
         LI,R8    C':'                                                  COBOL51
         STB,R8   0,R2                                                  COBOL51
         AI,R2    -2                                                    COBOL51
         LW,R9    SRR8              OLD SIZE OF FILE NAME               COBOL51
         AI,R9    2                 + 2 FOR F:                          COBOL51
         STB,R9   0,R2              PLACE IN FRONT OF F:                COBOL51
         BAL,LR   DECLXD            DECLARE NAME                        COBOL51
         LW,R2    DDBADB                                                COBOL51
         AI,R2    41                                                    COBOL51
         LW,R9    SRR8              RESTORE FILE NAME SIZE              COBOL51
         STB,R9   0,R2                                                  COBOL51
* OUTPUT WORD 0...DCB ADDRESS                                           COBOL51
         LI,R2    3                 STORE                               COBOL51
         LW,R9    ISECTM            DECLN OF INDEX AREA
         AI,R9    2                   +2 AS DCB DECLN
         STB,R9   DDC,R2             DECLARATION NUMBER                 COBOL51
         LI,R8    0                 STORE ZERO                          COBOL51
         STW,R8   DCR                AS DISPLACEMENT                    COBOL51
         BAL,LR   DC30              OUTPUT RELOCATABLE WORD             COBOL51
* OUTPUT WORD 1...STATUS INFORMATION WORD                               COBOL51
         LI,R8    0                 START STATUS WORD AT ZERO           COBOL51
         LH,R9    *DDBADW                                              COBOL51
         AND,R9   =3
         SLS,R9   20                                                   COBOL51
         STS,R9   R8                 SET LABEL RECORDS INDICATOR       COBOL51
         LI,R2    20                                                   COBOL51
         LB,R2    *DDBADW,R2         IF ERROR DECLARATIVE              COBOL51
         BNEZ     AI%R8              YES.                              COBOL51
         LI,R2    6                  NO.                               COBOL51
         LW,R2    *DDBADW,R2           OR FILE DECLARATIVE             COBOL51
         BNEZ     AI%R8              YES.                              COBOL51
         LI,R2    7                                                    COBOL51
         LW,R2    *DDBADW,R2           OR REEL DECLARATIVE             COBOL51
         BEZ      %+2                NO.                               COBOL51
AI%R8    EQU      %                                                    COBOL51
         AI,R8    X'40000'           YES. (ANY OF THE ABOVE)           COBOL51
*                                        SET DECLARATIVES PRESENT
         LI,R2    1
         LW,R2    *DDBADW,R2
         BLZ      BUFFR%1
         MTB,1    R8
BUFFR%1  EQU      %
         MTB,1    R8
NO%BLK   EQU      %
         STW,R8   DCA                STORE STATUS WORD AS OUTPUT        COBOL51
         BAL,LR   DC20              OUTPUT ABSOLUTE WORD                COBOL51
* OUTPUT WORD 2...CURRENT RECORD START AND CURRENT BUFFER ADDRESS       COBOL51
         LI,R8    0                 START WORD AT ZERO                  COBOL51
         LI,R2    X'40000'          IF RERUN FOR FILE                   COBOL51
         CW,R2    *DDBADW                                               COBOL51
         BAZ      NO%RERUN          NO.                                 COBOL51
         LW,R2    DDBADW            YES.                                COBOL51
         LW,R2    8,R2              IF END-OF-REEL                      COBOL51
         BNEZ     NO%RERUN          NO.                                 COBOL51
         LI,R8    -1                YES. SET COUNT-COMPARE TO -1        COBOL51
NO%RERUN EQU      %                                                     COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20              OUTPUT ABSOLUTE WORD                COBOL51
* OUTPUT WORD 3...CURRENT RECORD COUNT FOR RERUN                        COBOL51
*                 ...OR HIGHEST KEY WRITTEN FOR RANDOM OUTPUT           COBOL51
         LI,R8    0                 START COUNT AT ZERO                 COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                                                  COBOL51
* OUTPUT WORD 4...RERUN COUNT COMPARE                                   COBOL51
*                 ...OR BLOCK SIZE FOR RANDOM ORG.                      COBOL51
         LI,R2    4                                                     COBOL51
         LB,R2    *DDBADW,R2                                            COBOL51
         AND,R2   =X'3C'                                                COBOL51
         CI,R2    X'28'                                                 COBOL51
         BNE      CNTCMPR                                               COBOL51
         LW,R8    BLOKSZ            RANDOM                              COBOL51
         SLS,R8   16                                                    COBOL51
         LW,R9    BLOKSZ                                                COBOL51
         DW,R9    RECSZ                                                 COBOL51
         OR,R8    R9                                                    COBOL51
         STW,R8   DCA                PUT BLOCK SIZE IN H.W. 0           COBOL51
         BAL,LR   DC20                                                  COBOL51
         B        WORD5                                                 COBOL51
CNTCMPR  RES      0                                                     COBOL51
         LW,R2    DDBADW                                                COBOL51
         LW,R8    8,R2                                                  COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                                                  COBOL51
* OUTPUT WORD 5...SIZE OF CURRENT BLOCK (=0) ALTERNATE BUFFER (=0)      COBOL51
WORD5    RES      0                                                     COBOL51
         LI,R8    0                                                     COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                                                  COBOL51
* OUTPUT WORD 6...MAXIMUM RECORD LENGTH (FOR BLOCKED RECORDS ONLY) PLUS COBOL51
*                 LOGICAL RECORD ADDRESS                                COBOL51
         LW,R4    DDBN                                                  COBOL51
         LI,R2    X'80'                                                 COBOL51
         CB,R2    *DDBADW                                               COBOL51
         BAZ      NO%CHAIN                                              COBOL51
         LW,R2    DDBADB                                                COBOL51
         AI,R2    6                                                     COBOL51
         LB,R4    0,R2                                                  COBOL51
         SLS,R4   -2                                                    COBOL51
NO%CHAIN EQU      %                                                     COBOL51
         SLS,R4   2                                                     COBOL51
         AI,R4    1                                                     COBOL51
         LB,R8    DECLTB,R4                                             COBOL51
         STW,R8   SV                                                    COBOL51
         LI,R2    3                                                     COBOL51
         STB,R8   DDC,R2                                                COBOL51
         LW,R8    RECSZ                                                 COBOL51
         BNEZ     REC%ADDR          RECORD SIZE ZERO                    COBOL51
         STW,R8   DCA               YES..OUTPUT                         COBOL51
         BAL,LR   DC20                  WORD 6 = ABSOLUTE ZERO          COBOL51
         B        DCBPR                                                 COBOL51
REC%ADDR EQU      %                 NO..OUTPUT LOGICAL RECORD ADDRESS   COBOL51
         SLS,R8   17                                                    COBOL51
         STW,R8   DCR                                                   COBOL51
         BAL,LR   DC30                                                  COBOL51
* FILE INDEX AND STATUS AREA ALL DONE                                   COBOL51
*
* GENERATE DUMMY CONTROL SECTION FOR FILE DCB AREA
*
DCBPR    RES      0
*        DELETE OLD DEFINITION OF FILE NAME.                            COBOL51
*                                                                       COBOL51
         LW,R7    CRSF              CRS                                 COBOL51
         BEZ      DB1               NO                                  COBOL51
         LW,R12   NEWFL                                                 COBOL51
         LW,R13   ISSECT                                                COBOL51
         BAL,LR   GENORG            GENERATE ORIGIN ITEM                COBOL51
         MTW,4    NEWFL                                                 COBOL51
         LI,R8    0                                                     COBOL51
         STW,R8   DCR               ZERO DISPLACEMENT                   COBOL51
         LW,R8    ISECTM            DECLARATION NO OF I: NAME           COBOL51
         LI,R2    3                                                     COBOL51
         STB,R8   DDC,R2            DECLARATION NO.                     COBOL51
         BAL,LR   DC30              OUTPUT RELOACTABLE WORD             COBOL51
*
* INSTRUCTIONS DB1 THRU DB6 CALCULATE THE TOTAL SIZE OF THE DCB BY
* ADDING THE APPROPRIATE NUMBER OF INSN/OUTSNS AND READ/WRITE ACCT NOS.
* R7 CONTAINS THE RUNNING COUNT OF THE DCB SIZE
*
DB1      LB,R8    *DDBADW
         CI,R8    2                 IS THIS A SORT FILE ?
         BE       DB1D                YES, SET BOTH IN AND OUT BITS     COBOL51
         LW,R7    PDB                 NO, IS THIS MAIN OR SUB ?         COBOL51
         AND,R7   L(X'00000600')                                        COBOL51
         BEZ      DB1A                  NO                              COBOL51
DB1D     LI,R8    3                     YES, SET BOTH IN AND OUT BITS   COBOL51
         B        DB1B
DB1A     LI,R7    7
         LB,R8    *DDBADW,R7        LAST 3 BITS OF FILE HISTORY WORD
         AND,R8   L(X'7')             CONTAINS THE FUNCTION MODE
DB1B     STW,R8   OUTIN               4 = I/O  2 = OUT  1 = IN
         LI,R7    3
         LB,R8    *DDBADW,R7        FIELD D OF DDB
         AND,R8   L(X'7F')          REMOVE FLAG IF ON                   COBOL51
DB1C     STW,R8   NUMSN               = NUMBER OF INSN/OUTSNS
         STB,R8   DCBCD07,R7        STORE NUMSN INTO BYTE 3 OF
         LW,R7    DCBSIZE           START COUNTING WITH BASE SIZE OF DCB
         LW,R8    OUTIN
         CI,R8    1
         BE       %+2               INPUT ONLY - NO READ/WRITE ACCT NOS.COBOL51
         AI,R7    34                34 WORDS FOR READ/WRITE ACCT NOS.
         LW,R8    NUMSN             IF NUMSN = 0 DO NOT GENERATE INSNS
         BEZ      DB5                 OR OUTSNS
         LW,R8    OUTIN             CHECK FUNCTION MODE
         CI,R8    4
         BL       DB2
         LI,R8    7
         STW,R8   OUTIN             INPUT/OUTPUT - SET IN AND OUT BITS
DB2      AW,R7    NUMSN             ADD SERIAL NUMBERS                  COBOL51
         AI,R7    1                   AND CONTROL WORD                  COBOL51
DB4A     CW,R7    DCBMAXSZ          DOES THIS EXCEED DCB MAXIMUM SIZE?
         BLE      DB5                 NO
*
*  IF MAXIMUM DCB SIZE EXCEEDED, ISSUE DIAGNOSTIC AND RE-CALCULATE
*  DCB SIZE BASED ON 3 INSN/OUTSNS
*
         STW,R1   SAVER1              YES
         LW,R7    SRR8              PICK UP FIELD T TO CALCULATE NUMBER
*
* THE FOLLOWING INSTRUCTION SHOULD
* BE 'AI,R7 5'. HOWEVER, DUE TO AN
* ERROR IN COBOL21 (INSTRUCTIONS
* DB AND DB2) WHERE AN EXTRA BYTE
* WAS INTRODUCED IN THE SIZE OF
* THE DB CLUSTER, AN EXTRA BYTE IS
* USED IN THIS CALCULATION. THIS
* ERROR IN COBOL21 NECESSITATED A
* FIX IN COBOL31 ALSO (INSTRUCTION
* DBLINE+2 TO +6)
*
         AI,R7    5
         SLS,R7   -2                DETERMINE ADDRESS OF FIELD X
         AW,R7    DDBADW
         LW,R8    10,R7
         STW,R8   CARDNO            STORE FIELD X (SOURCE LINE NUMBER)
         LI,R1    233
         BAL,LR   DIAG              'MAXIMUM DCB SIZE EXCEEDED'
         LW,R1    SAVER1
         LI,R7    3
         LI,R8    3                 GENERATE 3 INSN/OUTSNS
         B        DB1C              RE-CALCULATE SIZE OF DCB
DB5      STB,R7   DCB0              TOTAL SIZE OF DCB GOES TO FIRST BYTE
         STW,R7   R8
         AI,R7    -8
DB6      STW,R7   DCB10             POINTER FOR KEY BUFFER
*
         SLS,R8   2                 DCB SIZE IN BYTES
         LI,R7    1
         STH,R8   DCSSIZE,R7        STORE INTO SIZE OF DUMMY CONTROL SEC
*
         LW,R9    DECLN             DECLARATION NO OF NAME
         STW,R9   DSECTN            SAVE DECLARATION NO. OF DDB NAME
         LW,R4    DDBN
         SLS,R4   2
         AI,R4    3
         STB,R9   DECLTB,R4         TO DECLAR. TABLE
         LW,R8    DCSSIZE           SIZE OF DUMMY CONTROL SECTION
         BAL,LR   DUMMY
* SET ORG OF F:FILE AREA TO ZERO
         LI,R12   0
         LW,R13   DSECTN
         BAL,LR   GENORG
*
* SET UP DCB DATA FIELDS
*
         LW,R8    L(X'80000011')    CONSEC,SEQUEN,SAVE DEFAULT OPTIONS
         LW,R7    *DDBADW
         AND,R7   L(X'800000')
         BEZ      %+2               ACCESS IS SEQUENTIAL
         AI,R8    X'01'             DIRECT
         LI,R7    3
         LW,R7    *DDBADW,R7
         BEZ      %+2               ORGANIZATION IS CONSECUTIVE
         AI,R8    X'10'             KEYED
         STW,R8   DCB5
*
* OUTPUT DATA WORDS TO DCB
*
*
* INSTRUCTIONS DC3 TO DC6 SET THE APPROPRIATE BITS IN WORDS 1 AND 2 OF
* THE DCBS FOR 'PRINTER', 'CARD-READER', AND 'CARD-PUNCH'.
*
*                     ASN  FUN  DEVF  DEV  VFC
*        PRINTER       3    2    0     3    1
*        CARD-READER   3    1    0     9    -
*        CARD-PUNCH    3    2    0     6    -
*
* ALSO THE FOLLOWING BITS ARE SET FOR A SORT-FILE (SD) :
*   (FILE,SRT) AND ASN = 1
*
* NOTE - IN THIS LISTING, ALL REFERENCES TO WORDS 1 AND 2 OF THE DCB
* REALLY MEAN WORDS 0 AND 1, ETC.
*
DC3      LI,R7    4                 CHECK V FIELD OF DDB FOR DEVICE TYPE
         LB,R8    *DDBADW,R7        FIELD V IS BITS 1-5 OF SECOND WORD
         SLS,R8   -2
         AND,R8   L(X'F')
         CI,R8    3                 V = 3 = PRINTER
         BNE      DC4
         LW,R8    DCB0P               SET UP FIRST 2 WORDS OF DCB
         OR,R8    DCB0                INSERT DCB SIZE FROM DCB0
         STW,R8   DCA
         BAL,LR   DC20
         LW,R8    DCB1P
         B        DC7
DC4      CI,R8    7                 V = 7 = CARD-READER
         BNE      DC5
         LW,R8    DCB0CR              SET UP FIRST 2 WORDS OF DCB
         OR,R8    DCB0                INSERT DCB SIZE FROM DCB0
         STW,R8   DCA
         BAL,LR   DC20
         LW,R8    DCB1CR
         B        DC7
DC5      CI,R8    8                 V = 8 = CARD-PUNCH
         BNE      DC6
         LW,R8    DCB0CP              SET UP FIRST 2 WORDS OF DCB
         OR,R8    DCB0                INSERT DCB SIZE FROM DCB0
         STW,R8   DCA
         BAL,LR   DC20
         LW,R8    DCB1CP
         B        DC7
*
* SET UP WORD 1 IF NOT PRINTER, CARD-READER, OR CARD-PUNCH
*
DC6      LW,R8    DCB0
         LB,R7    *DDBADW
         CI,R7    2                 IS THIS A SORT-FILE ?
         BNE      %+2                 NO
         OR,R8    L(X'1')             YES, SET ASN = 1
         STW,R8   DCA
         BAL,LR   DC20              WORD 1
         LW,R8    DCB1
DC7      STW,R8   DCA
         BAL,LR   DC20              WORD 2
         LW,R8    RECSZ             IF RECORD SIZE IS NON-ZERO
         BNEZ     %+5                GO TO PRODUCE RELOCATABLE 3RD WORD
         LW,R8    DCB2               ELSE PRESUMABLY THIS IS A REPORT
         STW,R8   DCA                FILE WITH NO RECORD AREA
         BAL,LR   DC20              WORD 3
         B        WD4
* OBTAIN DECLARATION NO. FOR RECORD-AREA
         LW,R4    DDBN              DDB NO. OF CURRENT FILE
         LB,R2    *DDBADW           DDB A FIELD
         AND,R2   =X'80'            TEST SAME CHAIN FLAG
         BEZ      DC8               0, NOT SAME, OR 1ST IN CHAIN
         LW,R2    DDBADB
         AI,R2    6                 DDB W FIELD ADDR
         LB,R4    0,R2              GET W FIELD
         SLS,R4   -2                KEEP DDB NO. (SHIFT OUT N.G.S)
DC8      SLS,R4   2
         AI,R4    1
         LB,R8    DECLTB,R4         GET DECLARATION NUMBER
         STW,R8   SV                SAVE DECLAR. NO OF FILE-NAME
         LI,R2    3
         STB,R8   DDC,R2            STORE IN OUTPUT ITEM
         LW,R8    DCB2
*                                   SET BUF FIELD TO ZERO,              COBOL51
         SLS,R8   -2                RELATIVE TO THE RECORD AREA DSECT
         STW,R8   DCR
         BAL,LR   DC30              WORD 3
*
* DECLARE ERROR, ABNORMAL ROUTINES AS EXTERNAL REFS
*
WD4      RES      0
         LI,R2    BA(ERX)           ERROR ROUTINE NAME
         LW,R8     ERXNUM          SIDR 4868 4/22/71                    COBOL51
         BNE       %+4             * USE EXISTING DECLARATION           COBOL51
         BAL,LR   DECLXR
         LW,R8    DECLN             ERROR ROUT. DECL. NO.
         STW,R8    ERXNUM                                               COBOL51
         LI,R2    3
         STB,R8   DDC,R2
         LW,R8    BLOKSZ            FOR A FOREIGN FILE PRIME RSZ FIELD
         BNEZ     RSZ               WITH THE BLOCK SIZE OTHERWISE USE
         LW,R8    RECSZ             THE LOGICAL RECORD SIZE UNLESS THIS
         BNEZ     RSZ               IS ZERO IN WHICH CASE THIS IS A
         LI,R8    134               REPORT FILE AND LINE LENGTH IS USED.
RSZ      RES      0                 PREPARE RSZ FIELD VALUE
         SLS,R8   17                TO BITS 0-14
         STW,R8   DCR
         BAL,LR   DC30              WORD 4
         LI,R2    BA(ABX)           ABNORMAL ROUTINE NAME
         LW,R8     ABXNUM                                               COBOL51
         BNE       %+4             * USE EXISTING DECLARATION           COBOL51
         BAL,LR   DECLXR
         LW,R8    DECLN
         STW,R8    ABXNUM                                               COBOL51
         LI,R2    3
         STB,R8   DDC,R2
         LW,R8    DCB4
         STW,R8   DCR
         BAL,LR   DC30              WORD 5
         LW,R8    DCB5
         STW,R8   DCA
         BAL,LR   DC20              WORD 6
         LW,R8    DSECTN            GET DECLARATION NO. OF DDB
         LI,R2    3
         STB,R8   DDC,R2
         LW,R8    DCB6              PREPARE FILE LIST POINTER
         STW,R8   DCR
         BAL,LR   DC30              WORD 7
         LW,R8    DCB7
         STW,R8   DCA
         BAL,LR   DC20              WORD 8
         LW,R8    DCB8
         STW,R8   DCA
         BAL,LR   DC20              WORD 9
         LW,R8    DCB9
         STW,R8   DCA
         BAL,LR   DC20              WORD 10
         LW,R8    DSECTN
         LI,R2    3
         STB,R8   DDC,R2
         LW,R8    DCB10             PREPARE KEY BUFFER POINTER
         STW,R8   DCR
         BAL,LR   DC30              WORD 11
         LW,R8    DCB11
         STW,R8   DCA
         BAL,LR   DC20              WORD 12
         LW,R8    DCB12
         LW,R2    DDBADB            IF A KEYED FILE
         LB,R2    3,R2              FILL KEYM FIELD OF DCB
         STB,R2   R8                WITH BYTE SIZE OF KEY
         STW,R8   DCA
         BAL,LR   DC20              WORD 13
         LW,R8    DCB13
         STW,R8   DCA
         BAL,LR   DC20              WORD 14
* GET DECLAR. FOR LABEL AREA
         LW,R8    LABDCL
         BEZ      DC14              NO LABELS SPECIFIED
         LW,R4    *DDBADW
         AND,R4   =X'030000'        DDB B BITS 6,7
         BEZ      DC14              =0, NOT LABELED FILES
*        SET TLABL IN DCB (REF. TO LABEL AREA)
         LI,R3    3
         STB,R8   DDC,R3
         LW,R8    DCB14
         STW,R8   DCR
         BAL,LR   DC30              WORD 15 RELOCATABLE
         B        DC15
DC14     LW,R8    DCB14
         STW,R8   DCA
         BAL,LR   DC20              WORD 15 ABSOLUTE
DC15     LW,R8    DCB15
         STW,R8   DCA
         BAL,LR   DC20              WORD 16
         LW,R8    DCB16
         STW,R8   DCA
         BAL,LR   DC20              WORD 17
         LW,R8    DCB17
         STW,R8   DCA
         BAL,LR   DC20              WORD 18
         LW,R2    DDBADB            IS THIS A
         LB,R2    3,R2               KEYED FILE?
         BNEZ     DC16              YES
         LW,R8    DCB18             NO -
         STW,R8   DCA                GENERATE ABSOLUTE
         BAL,LR   DC20                WORD 19
         B        DC17
DC16     LW,R8    DSECTM            DECLAR. NO. OF RECORD AREA
         LI,R2    3
         STB,R8   DDC,R2
         LW,R8    RECSZ             COMPUTE WORD DISPLACEMENT
         AW,R8    BLOKSZ             OF KEY BUFFER
         AI,R8    3                   FOR FILLING
         SLS,R8   -2                   KAD FIELD OF DCB
         STW,R8   DCR
         BAL,LR   DC30              WORD19
DC17     LW,R8    DCB19
         STW,R8   DCA
         BAL,LR   DC20              WORD 20
         LW,R8    DCB20
         STW,R8   DCA
         BAL,LR   DC20              WORD 21
         LW,R8    DCB21
         STW,R8   DCA
         BAL,LR   DC20              WORD 22
         LB,R5    *DDBADW
         CI,R5    2                 IS THIS A SORT FILE ?
         BNE      DC17A               NO
         LW,R8    DCBSRT22            YES, OUTPUT WORDS 23 AND 24
         STW,R8   DCA
         BAL,LR   DC20                WORD 23
         LW,R8    DCBSRT23
         STW,R8   DCA
         BAL,LR   DC20                WORD 24
         B        DC17B
DC17A    LW,R8    DCB22
         STW,R8   DCA
         BAL,LR   DC20              WORD 23
         LW,R8    DCBZERO
         STW,R8   DCA
         BAL,LR   DC20              WORD 24
DC17B    LI,R5    -13                                                   COBOL51
         LW,R8    DCB24+13,R5                                           COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20              WORDS 25-37                         COBOL51
         BIR,R5   %-3                                                   COBOL51
DC17C    LW,R8    DCB37             IF FILE IS INPUT ONLY               COBOL51
         LW,R5    OUTIN               AND ZERO INSN/OUTSNS SPECIFIED    COBOL51
         CI,R5    1                   THEN THIS IS THE LAST VARIABLE    COBOL51
         BNE      DC17D               ENTRY IN DCB. THUS BYTE 1         COBOL51
         LW,R5    NUMSN               MUST CONTAIN '01'                 COBOL51
         BNEZ     DC17D                                                 COBOL51
         OR,R8    L(X'00010000')                                        COBOL51
DC17D    STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20              WORD 38                             COBOL51
         LW,R8    DCBZERO                                               COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20              WORD 39                             COBOL51
         LW,R8    DCBZERO                                               COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20              WORD 40                             COBOL51
*
* INSTRUCTIONS DB7 THRU DB11 GENERATE THE REMAINDER OF THE VARIABLE
* LENGTH PARAMETERS FOR THE DCB ACCORDING TO THE FOLLOWING RULES:
*
*   1. READ/WRITE ACCOUNT NUMBERS ARE NOT GENERATED FOR INPUT ONLY FILES
*   2. OUTSN IS NOT GENERATED FOR INPUT  ONLY FILES
*   3. INSN  IS NOT GENERATED FOR OUTPUT ONLY FILES
*
DB7      LW,R5    OUTIN                                                 COBOL51
         CI,R5    1                                                     COBOL51
         BE       DB8               NO ACCT NOS. FOR INPUT ONLY FILES
         LW,R8    DCBCD05           CODE 05 READ ACCOUNT NUMBERS
         STW,R8   DCA
         BAL,LR   DC20
         LW,R8    DCBZERO
         STW,R8   DCA
         LI,R5    16
         BAL,LR   DC20                GENERATE 16 WORDS
         BDR,R5   %-1
         LW,R8    DCBCD06           CODE 06 WRITE ACCOUNT NUMBERS       COBOL51
         LW,R5    NUMSN                                                 COBOL51
         BNEZ     %+2                                                   COBOL51
         OR,R8    L(X'00010000')      IF LAST VARIABLE ENTRY            COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20
         LW,R8    DCBZERO
         STW,R8   DCA
         LI,R5    16
         BAL,LR   DC20                GENERATE 16 WORDS
         BDR,R5   %-1
DB8      LW,R5    NUMSN             IF NUMSN  = 0  DO NOT GENERATE SN'S COBOL51
         BEZ      DB11                                                  COBOL51
         LW,R8    DCBCD07           CODE 07 SERIAL NUMBERS              COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                                                  COBOL51
         LW,R5    NUMSN                                                 COBOL51
         LW,R8    DCBZERO                                               COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                GENERATE SERIAL NUMBERS           COBOL51
         BDR,R5   %-1                                                   COBOL51
DB11     LI,R5    8
         LW,R8    DCBZERO
         STW,R8   DCA
         BAL,LR   DC20              GENERATE 8 WORDS FOR KEY BUFFER
         BDR,R5   %-1
*
* SET UP TO LOOP TRU DBINDX FOR ALL FILES
DC19     LW,R4    DDBC
         CI,R4    50                50 IS MAX.
         BGE      ENDD              MAX 50 FILES
         AI,R4    1                 GET NEXT DDB NO.
         B        REP2
DC20     STW,LR   DCBB
         LI,R2    X'C2'             LISTING CONTROL BYTE
         STW,R2   LCB               LISTING CONTR. BYTE
         LI,R2    BA(DCC)+3         CONTR BYTE ADDR
         LI,R3    5                 ITEM SIZE
         BAL,LR   OBFOUT            OUTPUT ITEM
         B        *DCBB
DC30     STW,LR   DCBB
         LI,R2    X'C9'
         STW,R2   LCB               LISTING CONTR. BYTE
         LI,R2    BA(DDC)+2         CONTR. BYTE ADDR
         LI,R3    6                 ITEM SIZE
         BAL,LR   OBFOUT            OUTPUT ITEM
         B        *DCBB
DCBB     DATA     0
DCC      DATA,3   0
         DATA,1   X'44'             NON-RELOC. DCB ITEMS
DCA      DATA     0
DDC      DATA,2   0
         DATA,1   X'5A'             RELOCATABLE DCB ITEMS
         DATA,1   0                 DECLAR. NO.
DCR      DATA     0
ERX      DATA,1   5                 SIZE OF NAME
         DATA     C'C:ER'
         DATA,1   C'A'
         DATA,2   0
ABX      DATA,1   5                 SIZE
         DATA     C'C:AB'
         DATA,1   C'A'
         DATA,2   0
ERXNUM   DATA      0                                                    COBOL51
ABXNUM   DATA      0               * HOLD DECLARATION NUMBERS           COBOL51
DIAG224  RES      0
         LI,R1    4                                                     COBOL51
         LB,R1    *DDBADW,R1                                            COBOL51
         AND,R1   =X'3C'            NO DIAG FOR RANDOM FILE             COBOL51
         CI,R1    X'28'                                                 COBOL51
         BE       *LR                                                   COBOL51
         LW,R1    R5                GET HA DDB H
         SLS,R1   1                  . TO BA
         AI,R1    31                TO BA OF DDB T
         LB,R13   0,R1              SKIP DDB U
         AW,R1    R13
         AI,R1    4
         SLS,R1   -2
         LW,R13   0,R1              GET LINE NUMBER
         STW,R13  CARDNO
         LI,R1    224
         B        DIAG              ISSUE DIAG RETURN TO CALLER
*
DCSSIZE  DATA     X'00800000'       PP=10, SIZE OF DUMMY CONTROL SECTIONCOBOL51
*                 INSTRUCTION DB6+ INSERTS THE DCB SIZE IN SECOND HW.
DCBMAXSZ DATA     128               MAXIMUM SIZE OF DCB
*                 THIS VALUE MAY BE CHANGED IN THE FUTURE IF LATER
*                 VERSIONS OF BPM ALLOW LARGER SIZES OF DCBS.
DCBSIZE  DATA     48                BASE SIZE OF DCB                    COBOL51
*                 THIS NUMBER INCLUDES FIXED PORTION (22), FILENAME (9),
*                 ACCOUNT NUMBER (3), PASSWORD (3), EXPIRATION DATE (3),COBOL51
*                 AND KEY BUFFER (8).                                   COBOL51
*                 IT DOES NOT INCLUDE INSN/OUTSN OR READ/WRITE ACCT NOS.
*                 THIS VALUE IS INCREMENTED (SEE INSTRUCTIONS DB1 - DB6)
*                 AND THE TOTAL SIZE OF THE DCB IS PLACED IN BYTE 0
*                 OF WORD DCB0.
NUMSN    DATA     0                 NUMBER OF INSN/OUTSN
*                 THIS VALUE COMES FROM FIELD D OF THE DDB.
OUTIN    DATA     0                 FUNCTION MODE FROM FILE HISTORY WORD
*                 THIS VALUE COMES FROM THE LAST 3 BITS OF THE DDB
*                 4 = I/O  2 = OUT  1 = IN.
*
DCB0P    DATA     X'00000103'       WORD 0 PRINTER
DCB0CR   DATA     X'00000003'       WORD 0 CARD-READER
DCB0CP   DATA     X'00000003'       WORD 0 CARD-PUNCH
*
*                 WORD 0 WILL BE OR'ED WITH DCB0 WHICH CONTAINS
*                 THE ACTUAL DCB SIZE.
*
DCB1P    DATA     X'10040003'       WORD 1 PRINTER
DCB1CR   DATA     X'10020009'       WORD 1 CARD-READER
DCB1CP   DATA     X'10040006'       WORD 1 CARD-PUNCH
*
DCNT     DATA     0
DCBASE   DATA     0                 ADDR OF DATA BASE 4 (W.A.)
DCB0     DATA     X'FF000000'       WORD 0 OF DCB
*                 THE ACTUAL DCB SIZE (SEE INSTRUCTIONS DB1 - DB6)
*                 WILL REPLACE THE VALUE FF IN BYTE 0.
DCB1     DATA     X'10000000'
DCB2     DATA     X'40000000'       RELAT. ADDR FILE-NAME + BLOCK ORG.
DCB3     DATA     0                 RELAT. ADDR C:ERA
DCB4     DATA     0                 RELAT. ADDR C:ABA
DCB5     DATA     0
DCB6     DATA     22
DCB7     DATA     0
DCB8     DATA     0
DCB9     DATA     0
DCB10    DATA     X'FF'             POINTER TO KEY BUFFER
*                 THE CORRECT VALUE WILL BE STORED BY INSTRUCTION DB6.
DCB11    DATA     0
DCB12    DATA     0
DCB13    DATA     0
DCB14    DATA     0
DCB15    DATA     0
DCB16    DATA     0
DCB17    DATA     0
DCB18    DATA     0                 RELAT. ADDR DATA BASE 4
DCB19    DATA     0
DCB20    DATA     0
DCB21    DATA     0
DCB22    DATA     X'01000008'
DCB24    DATA     0
         DO       6
         DATA     0
         FIN
DCB31    DATA     X'02000002'
DCB32    DATA     0
DCB33    DATA     0
DCB34    DATA     X'03000002'
DCB35    DATA     0
DCB36    DATA     0
DCB37    DATA     X'04000002'       EXPIRATION DATE                     COBOL51
DCBCD05  DATA     X'05000010'       CODE 05 READ  ACCOUNT NUMBERS
DCBCD06  DATA     X'06000010'       CODE 06 WRITE ACCOUNT NUMBERS
DCBCD07  DATA     X'070100FF'       CODE 07 SERIAL NUMBERS              COBOL51
* THE ACTUAL NUMBER OF INSN/OUTSNS WILL REPLACE FF IN BYTE 3
* (SEE INSTRUCTIONS DB1C + 1)                                           COBOL51
DCBSRT22 DATA     X'01000108'       WORD 22 FOR SORT-FILE
DCBSRT23 DATA     X'03E2D9E3'       C'SRT' FOR SORT FILE-NAME
DCBZERO  DATA     0                 A ZERO WORD FOR GENERATING DCB
ENDD     RES      0                                                     COBOL51
         LW,R12   NEWFL             ANY I::%% ELEMENTS CREATED          COBOL51
         BEZ      END51             NO. PROCEED                         COBOL51
         LW,R13   ISSECT            YES. CHUNK OUT A ZERO WORD          COBOL51
         BAL,LR   GENORG                                                COBOL51
         LI,R8    0                                                     COBOL51
         STW,R8   DCA                                                   COBOL51
         BAL,LR   DC20                                                  COBOL51
         B        END51             THEN PROCEED                        COBOL51
         B        END51
DACCB    RES      1                 ROOM FOR CONTROL BYTES
DACOB    RES      21                DATA CONTR BLOCK
DDBADW   DATA     0                 WORD ADDR OF DDB
DDBADB   DATA     0                 BYTE ADDR OF DDB
RECSZ    DATA     0                 LOGICAL RECORD SIZE
BLOKSZ   DATA     0                 BLOCK SIZE
DUMSZ    DATA     0
DDBN     DATA     0                 CURRENT DDB NO.
DDBC     DATA     0
NUMDBS   DATA     0
SRR8     DATA     0                 FILE NAME SIZE
SR10     DATA     0                 SAVE R10 WORD
SV       DATA     0
SCR2     DATA     0
DSECTN   DATA     0                 DDB DECLARATION NO.
DSECTM   DATA     0                 REC AREA DECLARATION NO.
ISECTM   DATA     0                 INDEX AREA DECLARATION NO.
ISSECT   DATA     0                                                     COBOL51
NEWFL    DATA     0                                                     COBOL51
CRSF     DATA     0                 CO-RESIDENT SORT FLAG               COBOL51
         DATA     0                                                     COBOL51
DSI::    TEXTC    'I::%'                                                COBOL51
DKEY     RES      1
         TITLE    '*** BLOCK - BLOCK,RECORD SIZE ROUTINE ***'
         PAGE
*
*
*  BLOCK - GET BLOCK AND RECORD SIZE
*        IN       R5=H.W.A. OF DDB H FIELD
*        OUT      R5=H.W.A. OF DDB H FIELD
*                 R8=BLOCK SIZE (BYTES)
*                 R12=LOGICAL RECORD SIZE (BYTES)
BLOCK    RES      0
         LH,R12   0,R5
         AND,R12  =X'FFFF'
*        THE FOLLOWING CODE (UP TO BLK05) IS FOR SIDR 4693 IT WILL      COBOL51
*        ISSUE DIAG 226                                                 COBOL51
         BGZ      BLK05                                                 COBOL51
         LW,R4    R5                                                    COBOL51
         SLS,R4   1                 MAKE BYTE ADDRESS                   COBOL51
         AI,R4    31                ADDRESS OF T FIELD IN DDB           COBOL51
         LB,R13   0,R4              LOAD T FIELD                        COBOL51
         AW,R4    R13               ADD LENGTH TO DISPLACEMENT          COBOL51
         AI,R4    4                 ROUND TO NEXT WORD                  COBOL51
         SLS,R4   -2                WORD DISPLACEMENT                   COBOL51
         LW,R13   0,R4              ADDRESS OF X FIELD                  COBOL51
         STW,R13  CARDNO            USE LINE NO FROM DDB                COBOL51
         STW,LR   SAVELR                                                COBOL51
         STW,R1   SAVER1                                                COBOL51
         LI,R1    226               ISSUE DIAG                          COBOL51
         BAL,LR   DIAG              ISSUE DIAG                          COBOL51
         LW,R1    SAVER1            RESTORE REG                         COBOL51
         LW,LR    SAVELR            RESTORE REG                         COBOL51
BLK05    RES      0                                                     COBOL51
         LW,R4    R5
         AI,R4    -1
         LH,R8    0,R4              DDB G FIELD (BLOCK OPTION)
         BEZ      *LR               NO BLOCK SPECIFIED
         AND,R8   =X'FFFF'          SET +
         AI,R4    -4
         LH,R13   0,R4              GET DDB B
         CI,R13   8
         BANZ     BLK10             CHARACTERS OPTION
*  RECORDS SPECIFIED, GET (NO. OF REC.) * (REC. SIZE)
         STH,R8   BLK20             STORE BLOCKING FACTOR               COBOL51
         MH,R12   BLK20             MULTIPLY RECSZ TIMES FACTOR         COBOL51
         LW,R8    R13               GIVING BLOKSZ                       COBOL51
         B        *LR
*  CHARACTERS SPECIFIED
BLK10    RES      0
         CW,R8    R12               BLOCK SIZE : REC. SIZE
         BGE      *LR
*   GET LINE NO FROM DDB                                                COBOL51
         SLS,R4   1                 MAKE BYTE ADDRESS                   COBOL51
         AI,R4    41                DISPLACEMENT TO LENGTH OF  FD NAME  COBOL51
         LB,R13   0,R4              GET LENGTH OF NAME                  COBOL51
         AW,R4    R13               ADD LENGTH TO DISPLACEMENT          COBOL51
         AI,R4    4     1 MORE PLUS 3 TO ROUND TO NEXT WORD             COBOL51
         SLS,R4   -2                GET WORD DISPLACEMENT               COBOL51
         LW,R13   0,R4              GET LINE NO OF FD                   COBOL51
         STW,R13  CARDNO
         STW,LR   SAVELR            SAVE NEEDED REGISTER CONTENTS
         STW,R1   SAVER1             BEFORE CALL TO DIAG
         LI,R1    121
         BAL,LR   DIAG              BLOCK IS SMALLER THAN REC.
         LW,R8    R12               SET TO AT LEAST REC SIZE
         LW,R1    SAVER1
         B        *SAVELR
BLK20    DATA     0
SAVELR   RES      1
SAVER1   RES      1
         TITLE    '*** REPORT PROCESSING ***'
         PAGE
*
* REPORT - GENERATE DUMMY CONTR. SECTIONS FOR REPORTS
*
REPORT   RES      0
         LI,R3    12
         LB,R4    *DDBADW,R3
         STW,R4   DDBN
         LW,R2    DDBADB
         AI,R2    13                BYTE ADDR N, NAME
         BAL,LR   DECLXD            DECLARE XTRNL. DEF.
         LW,R9    DECLN             DECLAR. NO.
         LW,R4    DDBN
         SLS,R4   2
         AI,R4    1
         STB,R9   DECLTB,R4         TO TABLE
         LI,R2    2
         LW,R8    *DDBADW,R2
         AND,R8   =X'FFFF'          D.C.S. SIZE
         BAL,LR   DUMMY             DECLARE DUMMY CONTR. SECT.
         LW,R2    DDBADB
         AI,R2    13
         LB,R8    0,R2              N = CHARACTER COUNT
         STW,R8   REPNN             SAVE CHAR. COUNT
         AI,R8    2                 +2 FOR R:
         LI,R9    C':'
         STB,R9   0,R2              INSERT :
         AI,R2    -1
         LI,R9    C'R'
         STB,R9   0,R2              INSERT R
         AI,R2    -1
         STB,R8   0,R2              INSERT NEW N
         BAL,LR   DECLXD            DECLARE R:NAME
         LW,R9    REPNN
         LI,R4    13                RESTORE CHAR. COUNT
         STB,R9   *DDBADW,R4
         LW,R9    DECLN             DECL. NO.
         LW,R4    DDBN
         SLS,R4   2
         AI,R4    2
         STB,R9   DECLTB,R4         TO TABLE
         LI,R2    4
         LH,R8    *DDBADW,R2
         AND,R8   =X'FFFF'          D.C.S. SIZE
         BAL,LR   DUMMY             DECLARE DUMMY CONTR. SECT.
         B        DC19              GET NEXT DB.
REPNN    DATA     0
         TITLE    '*** DUMMY CONTROL SECTION ROUTINE ***'
         PAGE
*
*DUMMY   GENERATE,OUTPUT DUMMY CONTROL SECTION ITEM
*        R8=SIZE OF SECTION (BYTES)
*        R9=DECLARATION NO. OF SECTION NAME
*
DUMMY    RES      0
         STW,LR   DB
         STB,R9   R8                DECLAR. NO.
         STW,R8   DUMSEC
         LI,R2    BA(DUMSEC)-1
         LI,R3    5                 SIZE OF ITEM
         BAL,LR   OBFOUT            OUTPUT ITEM
         LI,R2    1
         AWM,R2   DECLN
         B        *DB
DB       DATA     0
         DATA,3   0                 SPACER
         DATA,1   X'09'             CONTR. BYTE
DUMSEC   DATA     0                 DECL NO., ACCESS CODE 0, SIZE
         END
