//ZDUMPTP  JOB (TSO),
//             'Install ZDUMPTP',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//* ********************************************************            00020000
//* *  INSTALL THE 'ZDUMPTP'  PROGRAM                      *            00030000
//* ********************************************************            00040000
//ZDUMPTP  EXEC ASMFCL                                                  00050000
//SYSIN    DD *                                                         00060000
DMP      TITLE '      AFDSC  FILE  DUMP  UTILITY      '
*--------------------------------------------------------------------**
*        INITIALIZATION AND CONTROL CARD ANALYSIS                     *
*                                                                     *
*   CONTROL CARD FORMAT                                               *
*                                                                     *
*    FILES=N   - NO  OF CONSEQ. FILES TO DUMP    (NOMINAL VALUE = 1)  *
*    REC=N     - NO. OF CONSEQ. RECORDS TO DUMP  (NOMINAL VALUE = ALL)*
*    SKPFIL=N  - NO. OF CONSEQ. FILES TO SKIP    (NOMINAL VALUE = 0)  *
*    SKPREC=N  - NO. OF CONSEQ. RECORDS TO SKIP  (NOMINAL VALUE = 0)  *
*    PRINT=YES - PRINT RECORD BESIDE DUMP        (NOMINAL VALUE = YES)*
*          NO. - DO NOT PRINT RECORD (DUMP ONLY)                      *
*    RUN=YES   - REWIND AND UNLOAD SO THAT THE NEXT CONTROL           *
*                CARD MAY BE USED ON A NEW TAPE   (NOMINAL VALUE = NO)*
*  * MULTIPLE TAPE DUMPS NOT SUPPORTED FROM CONSOLE * * * * *         *
*    REDUN=NO  - EXIT TO END OF JOB ON REDUNDENT RECORD (NOM. VAL= NO)*
*          YES - DUMP REDUNDENT RECORDS  (MAX OF 10)                  *
*                (ALL REDUNDENT RECORDS ARE SO INDICATED)             *
*    MODE=NN   - TAPE DRIVE MODE SET COMMAND CODE                     *
*        |  MODE    BPI    PARITY   TRANSLATE      CONVERT  |         *
*        |  ____    ___    ______   _________      _______  |         *
*        |   10     200     ODD        OFF            ON    |         *
*        |   20     200     EVEN       OFF           OFF    |         *
*        |   28     200     EVEN       ON            OFF    |         *
*        |   30     200     ODD        OFF           OFF    |         *
*        |   38     200     ODD        ON            OFF    |         *
*        |   50     556     ODD        OFF            ON    |         *
*        |   60     556     EVEN       OFF           OFF    |         *
*        |   68     556     EVEN       ON            OFF    |         *
*        |   70     556     ODD        OFF           OFF    |         *
*        |   78     556     ODD        ON            OFF    |         *
*        |   90     800     ODD        OFF            ON    |         *
*        |   A0     800     EVEN       OFF           OFF    |         *
*        |   B0     800     ODD        OFF           OFF    |         *
*        |   B8     800     ODD        ON            OFF    |         *
*        |   C0     800     SINGLE DENSITY 9-TRACK TYPE     |         *
*        |   C0     1600    DUAL DENSITY 9-TRACK TYPE       |         *
*        |   C8     800     DUAL DENSITY 9-TRACK TYPE       |         *
*                                                                     *
* CHANGED IN DEC '77 TO FIX PROBLEM OF TAPES RUNNING PAST DOUBLE TAPE *
* MARKS. THE FIX... EACH TIME A TAPE MARK IS ENCOUNTERED (FSF, FSR,   *
* OR READ), A READ IS DONE TO SEE IF ANOTHER TAPE MARK IMMEDIATELY    *
* FOLLOWS. IF SO (UNIT EXCEPTION), A MESSAGE IS PRINTED, AND THE      *
* PROGRAM TERMINATES. IF NOT, THE TAPE IS BACKSPACED TO THE BEGINNING *
* OF THE BLOCK JUST READ AND FLOW PROCEDES AS NORMAL. CHRIS MARKLE SFI*
*                                                                     *
*  CODE CHECKED OUT WITH IBM 3480'S IN FULL FUNCTION MODE. WORKS      *
*  GREAT.   OCT 1986  JIM MARSHALL                                    *
*                                                                     *
*  DID SOME CLEANING UP OF THE CODE. JAN 1990 JDM                     *
*                                                                     *
*---------------------------------------------------------------------*
         SPACE 3
RZ       EQU   0
R0       EQU   0
R1       EQU   1
BASE     EQU   2         BASE
R2       EQU   2
         SPACE 1
R3       EQU   3
W1       EQU   4         WORK
R4       EQU   4
W2       EQU   5         WORK
R5       EQU   5
V        EQU   6         VOLITAL
R6       EQU   6
R7       EQU   7
R8       EQU   8
R9       EQU   9
R10      EQU   10
         SPACE 1
PRTAD    EQU   10        PRINT DATA ADDR
PRTCT    EQU   11        PRINT DATA CT
R11      EQU   11
SL       EQU   12        SUB LINK REG
R12      EQU   12        SAVE AREA
R13      EQU   13        SAVE AREA
R14      EQU   14
R15      EQU   15
         SPACE 3
FSFC     EQU   X'3F'
FSRC     EQU   X'37'
RDC      EQU   X'02'
RUNC     EQU   X'0F'
REWC     EQU   X'07'
SETMC    EQU   X'03'
PTE      EQU   131
         EJECT
* ZDUMPTP  AMODE 24                                               *JLM*
* ZDUMPTP  RMODE 24                                               *JLM*
ZDUMPTP  CSECT
         SAVE (14,12)
         BALR  R2,0
         USING *,R2
         ST    R13,MYSAVE+4
         LA    R8,MYSAVE
         ST    R8,8(R13)
         LR    R13,R8
         SPACE 1
         SR    V,V
         STH   V,REDCT
         LH    RZ,=H'30000'        INITALIZE ROUTINE
         GETMAIN  R,LV=(0)         GET READ BUF CORE  (30,000 BYTES)
         ST    R1,BUF
         L     R3,16               GET CVT POINTER
         L     R4,0(R3)            GET TCB POINTER
         L     R4,4(R4)            GET TCB
         L     R4,12(R4)           GET TIOT
         LA    R4,24(R4)           GET DD ENTRY
TIOTSCAN CLC   0(4,4),TIOTEND      ALL DD'S CHECKED ?
         BE    CONSOLE             YES
         LA    R5,4(R4)            GET DDNAME
         CLC   0(8,5),SYSINDD
         BE    INSTREAM
         SR    R5,R5
         IC    5,0(4)              INSERT DD ENTRY LENGTH
         AR    R4,R5               UPDATE TIOT POINTER
         B     TIOTSCAN
SYSINDD  DC    CL8'SYSIN   '
TIOTEND  DC    F'0'
MYECB    DC    F'0'
BOBECB   DC    F'0'
         DS    0H
CONSOLE  EQU   *
         WTOR  'SFI001A ** ENTER VOLUME SERIAL NUMBER OF TAPE TO BE DUM|
               PED **',NUMBER,6,BOBECB                          PLP
         WAIT  ECB=BOBECB                                       PLP
         MVI   MYSWITCH,X'FF'
         B     AGOGO
MYSWITCH DC    X'00'
         DS    0H
INSTREAM EQU   *
         OPEN (SYSIN,(INPUT))
AGOGO    OPEN (SYSPRINT,(OUTPUT))
         RDJFCB (FILE)
         CLI   MYSWITCH,X'FF'                                   PLP
         BNE   CONTINUE                                         PLP
         MVC   JFCB+118(6),NUMBER                               PLP
         WTOR  'SFI001A ** ENTER ZDUMP CONTROL INFORMATION **',CARD,80,|
               MYECB                                            PLP
         WAIT  ECB=MYECB                                        PLP
CONTINUE MVI   JFCB+66,X'10'                                    PLP
         OPEN  (FILE,(INPUT)),TYPE=J
         MVI   CCW,REWC
         BAL   SL,TAPEIO
         NI    FLG,X'FF'-FIRSTCC
*        CALL  DATETIME
*        MVC   TIME(8),16(R1)
*        MVC   DATE(8),4(R1)
         SPACE 1
RESTART  EQU   *
CLOSESW  NOP   LEAVE
         MVC   FILENO(2),=PL2'+1'  SETUP WITH NOMINAL VALUES
         MVI   CCWMODE,SETMC
         MVC   RECNO(4),=PL4'+1'
         SR    V,V
         STH   V,FILESKCT          FILE SKIP CT = 0
         STH   V,RECSKCT           REC SKIP CT = 0
         OC    FLG(1),NOMINFLG     SET NOMINAL FLAG BYTE
         STH   V,RECCT
         MVC   FILECT(2),=H'1'     NO. FILES TO DUMP
         SPACE 2
         TM    MYSWITCH,X'FF'
         BNO   GETCARD
         OI    CLOSESW+1,X'F0'     FORCE DEPARTURE
         B     BYCARD
GETCARD  GET   SYSIN,CARD
BYCARD   OI    FLG,FIRSTCC
PUTCARD  EQU   *
         LA    PRTAD,CARD
         LA    PRTCT,L'CARD
         BAL   SL,LIST             PRINT CONTROL CARD
         SPACE 2
         LA    V,CARD-1
         LR    W2,V
GETPARM  EQU   *
         LR    V,W2
         BAL   SL,FILL             GET PARM
         LTR   V,V                 END OF CARD ?
         BZ    ENDCC               YES
         MVC   BSV,BUC             SAVE PARM
         BAL   SL,FILL             GET PARM VALUE
         LR    W2,V
         LTR   V,V
         BZ    ENDCC
         CLC   BSV(5),=C'FILES'    FILES ?
         BE    FILES
         CLC   BSV(6),=C'SKPFIL'   SKPFIL ?
         BE    SKPFIL
         CLC   BSV(6),=C'SKPREC'   SKPREC ?
         BE    SKPREC
         CLC   BSV(5),=C'PRINT'    PRINT ?
         BE    PRINT
         CLC   BSV(5),=C'REDUN'    REDUN ?
         BE    REDUN
         CLC   BSV(3),=C'RUN'      RUN   ?
         BE    RUN
         CLC   BSV(3),=C'REC'      REC ?
         BE    REC
         CLC   BSV(4),=C'MODE'     MODE SET ?
         BE    MODE    YES
         SPACE 1
         B     CCERROR
         EJECT
*---------------------------------------------------------------------*
*    CONTROL CARD PARAMETER ROUTINES
*---------------------------------------------------------------------*
         SPACE 2
FILES    EQU   *                   FILES
         BAL   SL,CONVB            CONVERT TO BINARY
         STH   R1,FILECT
         B     GETPARM
         SPACE 2
REC      EQU   *                   REC
         SR    R1,R1
         CLC   BUC(3),=C'ALL'
         BE    REC4
         BAL   SL,CONVB            CONVERT NO. RECS.
REC4     STH   R1,RECCT            STORE NO. RECS. TO BE DUMPED
         B     GETPARM
         SPACE 2
SKPFIL   EQU   *    SKPFIL
         BAL   SL,CONVB  CONVERT NO.
         STH   R1,FILESKCT
         B     GETPARM
         SPACE 2
SKPREC   EQU   *    SKPREC
         BAL   SL,CONVB            CONVERT NO.
         STH   R1,RECSKCT
         B     GETPARM
         SPACE 2
PRINT    EQU   *    PRINT
         NI    FLG,X'FF'-PRINTF    SET NO
         CLC   BUC(3),=C'YES'      IS IT YES
         BNE   GETPARM             NO
         OI    FLG,PRINTF          SET YES
         B     GETPARM
         SPACE 2
REDUN    EQU   *    REDUN
         NI    FLG,X'FF'-REDUNF    SET REDUN=NO
         CLC   BUC(3),=C'YES'      REDUN=YES ?
         BNE   GETPARM             NO
         OI    FLG,REDUNF          SET REDUN  FLAG ON
         B     GETPARM
         SPACE 2
RUN      EQU   *    RUN
         NI    FLG,X'FF'-RUNF      SET RUN=NO
         CLC   BUC(3),=C'YES'      IS IT REALLY RUN=YES
         BNE   GETPARM             NO
         OI    FLG,RUNF            SET RUN=YES
         B     GETPARM
         SPACE 2
MODE     EQU   *    MODE
         CLC   BUC(2),=C'  '
         BNH   CCERROR
         TR    BUC(2),HEXTRT-C'A'
         PACK  DBW(2),BUC(3)       CONVERT 2 NOS. TO HEX
         OC    CCWMODE(1),DBW      "OR" TO SET MODE CCW
       B       GETPARM
         EJECT
*---------------------------------------------------------------------*
*    FOREWARD SPACE FILE LOGIC
*---------------------------------------------------------------------*
         SPACE 2
ENDCC    EQU   *                   BEGIN PROCESSING
         MVC   SAVERCT(2),RECCT
         SPACE 1
FSFTAPE  EQU   *
         LH    V,FILESKCT          FSF COUNT
         LTR   V,V                 FSF ZERO ?
         BZ    RECORDSK
         SPACE 1
         BCTR  V,0                 DECREMENT FSF CT
         STH   V,FILESKCT
         SPACE 1
         AP    FILENO(2),=P'+1'
         MVI   CCW,FSFC            SET FSF OP CODE
         BAL   SL,TAPEIO           FSF TAPE
         BAL   SL,TESTEOF              **** C.A.M. AFDSC DEC '77 ****
         B     FSFTAPE
         SPACE 2
RECORDSK EQU   *
         LH    V,FILECT            DECREMENT FILE COUNT
         BCTR  V,0
         STH   V,FILECT
         SPACE 1
         LH    W1,RECSKCT          REC. SKIP CT
RECSKTST LTR   W1,W1               IS REC SKIP CT ZERO
         BZ    TAPEDPIN            YES
         SPACE 1
         MVI   CCW,FSRC            SET FSR OP CODE
         BAL   SL,TAPEIO           FOREWARD SPACE RECORD
         BCTR  W1,0                DECR. REC SKIP CT
         AP    RECNO(4),=P'+1'
         B     RECSKTST
         SPACE 2
         EJECT
*---------------------------------------------------------------------*
*     FILE DUMP MAIN LOGIC
*---------------------------------------------------------------------*
         SPACE 2
TAPEDPIN EQU   *
         MVI   CCW,RDC   SET READ CODE
         SPACE 1
         MVC   CCW+1(3),BUF+1      SET BUFFER ADDR AND COUNT
         MVC   CCW+6(2),=H'30000'
         SPACE 2
BLDRECHD EQU   *
         MVI   PRTLINE,X'13'
         PUT   SYSPRINT,PRTLINE    SPACE 2 LINES
         AP    LNCT(2),=P'+2'
         MVC   DBW(6),=X'402020202020'
         ED    DBW(6),RECNO+1      CONVERT CURRENT REC & FILE NO.
         OI    DBW+5,X'F0'
         MVC   RECHDR+9(5),DBW+1
         SPACE 1
         MVC   DBW(4),=X'402020202020'
         ED    DBW(4),FILENO
         OI    DBW+3,X'F0'
         MVC   RECHDR+23(3),DBW+1
         SPACE 2
         BAL   SL,TAPEIO           READ A TAPE BLOCK
         LH    V,=H'30000'
         SH    V,CSW+6
         STH   V,BYTECT            GET BYTE COUNT
         SPACE 1
         CVD   V,DBW
         MVC   RECHDR+29(6),=X'402020202020'
         ED    RECHDR+29(6),DBW+5
         OI    RECHDR+34,X'F0'     PLACE BYTE COUNT IN HEADER
         LA    PRTAD,RECHDR
         LA    PRTCT,L'RECHDR
         BAL   SL,LIST             PRINT DUMP RECORD HEADING
         SPACE 2
         BAL   SL,DISPLAY          DISPLAY TAPE RECORD
         SPACE 1
         AP    RECNO(4),=P'+1'     BUMP REC NO.
         LH    V,RECCT
         BCTR  V,0                 DECREMENT CT OF RECORDS YET TO PRT
         STH   V,RECCT
         LTR   V,V                 ALL RECORDS PRINTED
         BNZ   BLDRECHD            NO
         SPACE 2
FILETST  EQU   *
         LH    V,FILECT
         LTR   V,V                 ALL FILES PRINTED YET
         BZ    RUNTEST             YES
         MVI   CCW,FSFC
         TM    CSW+4,X'01'         EOF ALREADY
         BO    *+8
         BAL   SL,TAPEIO           FSF TAPE
         BAL   SL,TESTEOF              **** C.A.M. AFDSC DEC '77 ****
         AP    FILENO(2),=P'+1'
         MVC   RECNO(4),=PL4'+1'
         MVC   RECCT(2),SAVERCT
         B     RECORDSK
         SPACE 2
RUNTEST  EQU   *
         TM    FLG,RUNF            REWIND & UNLOAD ?
         BZ    RESTART             NO
         SPACE 1
         MVI   CCW,RUNC
         BAL   SL,TAPEIO           REWIND AND UNLOAD
         B     RESTART
         SPACE 2
**** C.A.M. AFDSC DEC '77 ****
TESTEOF  EQU   *
         MVI   CCW,RDC
         EXCP  TAPEIOB
         WAIT  ECB=TAPEECB
         CLI   TAPEECB,X'7F'
         BE    BSR
         LA    PRTAD,DBLEOF
         LA    PRTCT,L'DBLEOF
         BAL   SL,LIST
         B     LEAVE
BSR      EQU   *
         MVI   CCW,BSRC
         EXCP  TAPEIOB
         WAIT  ECB=TAPEECB
         CLI   TAPEECB,X'7F'
         BCR   8,SL
         ABEND 1,,STEP
         SPACE 1
DBLEOF   DC    C'*** DOUBLE END OF FILE TAPE MARKS ENCOUNTERED ***'
         DS    0H
BSRC     EQU   X'27'
**** END C.A.M. AFDSC DEC '77 ****
         EJECT
*---------------------------------------------------------------------*
*    TAPE I/O LOGIC
*---------------------------------------------------------------------*
         SPACE 2
TAPEIO   EQU   *    ENTRY
         ST    SL,TAPERSV     SAVE RETURN
         XC    TAPEECB,TAPEECB
         EXCP  TAPEIOB        START TAPE I/O
         WAIT  ECB=TAPEECB
         CLI   TAPEECB,X'7F'       I/O ERRORS
         BNE   TAPEIOER            YES
         SPACE 1
         SPACE 2
         BR    SL        RETURN
         SPACE 3
TAPEEOF  EQU   *
         CLI   CCW,RDC        READ COMMAND ?
         BNE   TAPEFSR       NO
TAPEEOFM EQU   *
         MVI   PRTLINE,X'13'
         PUT   SYSPRINT,PRTLINE    SPACE 2
         AP    LNCT,=P'+2'
         LA    PRTAD,EOFMSG
         LA    PRTCT,L'EOFMSG
         BAL   SL,LIST             PRINT EOF MSG
         SPACE 1
         B     FILETST
         SPACE 2
TAPEFSR  EQU   *
         CLI   CCW,FSRC            FSR  COMMAND ?
         BCR   7,SL                RETURN
         SPACE 1
         B     TAPEEOFM
         SPACE 2
TAPEIOER EQU   *    TAPE ERROR ENTRY
         LA    V,FILE
         USING IHADCB,V
         NI    DCBIFLGS,X'3F'
         DROP  V
         TM    CSW+4,X'01'   END OF FILE ?
         BO    TAPEEOF         YES
         LH    V,REDCT
         LA    V,1(0,V)       BUMP REDUN. CT
         STH   V,REDCT
         CH    V,=H'10'       10 I/O ERRORS ?
         BNL   GV10REDM       YES
         UNPK  DBW(3),TAPEECB(2)
         TR    DBW(2),DMPTRNS-X'F0'
         MVC   REDCC+5(2),DBW
         LA    PRTAD,REDUNM
         LA    PRTCT,L'REDUNM+L'REDCC
         BAL   SL,LIST        PRINT REDUN. MSG
         SPACE 1
         L     SL,TAPERSV
         CLI   TAPEECB,X'48'       HAS I/O BEEN PURGED
         BE    LEAVE    YES
         BR    SL             RETURN
         SPACE 2
GV10REDM EQU   *
         MVI   PRTLINE,X'19'
         LA    PRTAD,REDEOJ
         PUT   SYSPRINT,PRTLINE     SPACE 3
         LA    PRTCT,L'REDEOJ
         BAL   SL,LIST        PRINT 10 CONSEQ REDUN MSG
         SPACE 2
         MVI   CCW,REWC
         EXCP  TAPEIOB        REWIND TAPE
         B     LEAVE
         EJECT
*---------------------------------------------------------------------*
*    PRINT ROUTINE
*---------------------------------------------------------------------*
LIST     EQU   *        ENTRY
         AP    LNCT(2),=P'+1'
         CP    LNCT(2),LNMAX       EJECT FORMS NEEDED
         BL    LISTPRT             NO
         SPACE 1
         MVC   LNCT(2),=PL2'+0'    RESET COUNTER
         AP    PGCT,=P'+1'    BUMP PAGE COUNT
         MVC   PAGE+4(4),=X'40202120'
         ED    PAGE+4(4),PGCT
         OI    PAGE+7,X'F0'
         MVI   TITLE,X'8B'
         PUT   SYSPRINT,TITLE      EJECT FORMS
         MVI   TITLE,25
         PUT   SYSPRINT,TITLE      PRINT TITLE
         SPACE 2
LISTPRT  EQU   *
         BCTR  PRTCT,0
LISTNOP  NOP   LISTPRT4
         MVI   PRTLINE,C' '
         MVC   PRTLINE+1(132),PRTLINE    BLANK LINE
         EX    PRTCT,LISTMOVE      MOVE LINE TO BUFFER
LISTPRT4 EQU   *
         MVC   PRTLINE(1),PRTCODE
         PUT   SYSPRINT,PRTLINE    PRINT LINE
         LA    PRTCT,1(0,PRTCT)
         BR    SL                  RETURN
         SPACE 2
         EJECT
*---------------------------------------------------------------------*
*    CONVERSION TO BINARY ROUTINE
*---------------------------------------------------------------------*
         SPACE 2
CONVB    EQU   *
         SPACE 1
         LA    V,BUC
         SR    R1,R1
         CLI   BUC,C' '
         BCR   8,SL
CONVBTS  CLI   0(V),C'0'           IS CHAR VALID DIGIT
         BL    CCERROR             NO
         CLI   0(V),C'9'
         BH    CCERROR
         LA    V,1(0,V)   BUMP TO NEXT CHAR
         LA    R1,1(0,R1)
         CLI   0(V),C' '
         BNE   CONVBTS
         SPACE 1
         BCTR  R1,0
         EX    R1,CONVBPK     PACK NO
         CVB   R1,DBW         CONVERT NO. IN BUC TO BINARY
         BR    SL        RETURN
         SPACE 3
ABORTMSG EQU   *
         MVI   PRTLINE,X'19'
         PUT   SYSPRINT,PRTLINE    SPACE 3 LINES
         LA    PRTAD,DGEREOJ
         LA    PRTCT,L'DGEREOJ
         BAL   SL,LIST          PRINT BAD DIGIT EOJ MSG
         TM    MYSWITCH,X'FF'
         BNO   GOOUT
         WTO   '*** CONTROL INFORMATION ERROR ***  #EOJ#'
GOOUT    B     LEAVE
         SPACE 3
LEAVE    EQU   *
         TM    MYSWITCH,X'FF'
         BO    LEAVE1
         CLOSE (SYSIN)
LEAVE1   CLOSE (SYSPRINT,,FILE)
         L     13,MYSAVE+4
         RETURN  (14,12),RC=0
         SPACE 1
         EJECT
CCEOF    EQU   *         CONTROL CARD EOF
         OI    CLOSESW+1,X'F0'
         TM    FLG,FIRSTCC    CONTROL CARD MISSING
         BO    LEAVE          NO
         SPACE 1
         MVI   CARD,C' '
         MVC   CARD+1(79),CARD   BLANK CARD
         MVC   CARD(L'NOMCC),NOMCC   MOVE IN NOMINAL CC
         B     PUTCARD
         SPACE 2
CCERROR  EQU   *    CONTROL CARD ERROR
         LA    PRTAD,BADCCM        BAD CC MSG
         LA    PRTCT,L'BADCCM
         BAL   SL,LIST             PRINT BAD CONTROL CARD MSG
         B     ABORTMSG
         EJECT
FILL     EQU   *
         MVI   BUC,C' '
         MVC   BUC+1(11),BUC
         LA    V,1(,V)
FILL2    CLI   0(V),C' '
         BNE   FILL4
         LA    V,1(,V)
         C     V,=A(CARD+79)
         BL    FILL2
         SR    V,V
         BR    SL
         SPACE 2
FILL4    LA    R1,BUC
FILL6    CLI   0(V),C','
         BE    FILL8
         CLI   0(V),C'='
         BE    FILL8
         CLI   0(V),C' '
         BE    FILL8
         MVC   0(1,R1),0(V)
         LA    R1,1(,R1)
         LA    V,1(,V)
         C     V,=A(CARD+79)
         BL    FILL6
         SR    V,V
         SPACE 2
FILL8    BR    SL
         EJECT
*---------------------------------------------------------------------*
*  RECORD DISPLAY ROUTINE
*---------------------------------------------------------------------*
         SPACE 2
DISPLAY  EQU   *
         ST    SL,DSPRSV
         MVI   LISTNOP+1,X'F0'   BYPASS BLANK OF PRTLINE BY LIST
         L     V,BUF          INITIALIZE ROUTINE
         AH    V,BYTECT
         ST    V,ENDBUF                 SET END OF BUFFER ADDR
         MVC   LINEAD(4),=PL4'+0'       SET LINE ADDR
         SPACE 1
         MVI   PRTLINE,C' '
         MVC   PRTLINE+1(132),PRTLINE        BLANK LINE
         LA    V,PRTLINE
         TM    FLG,PRINTF          PRINT ?
         BO    DSPSETP2            YES
         MVC   LINEADIN(2),=P'+48'   LINE ADDR INCR.
         MVC   BUFINC(2),=H'48'
         LA    V,126(0,V)       SET END OF LINE
         B     DSPSETP4
DSPSETP2 LA    V,86(0,V)        SET END OF LINE
         MVC   LINEADIN(2),=P'+32'  LINE ADDR INCR
         MVC   BUFINC(2),=H'32'
         SPACE 2
DSPSETP4 EQU   *
         L     W1,BUF
         ST    V,ENDLINE
         SPACE 2
RESTRTLN EQU   *
         ST    W1,BEGBLN
         LA    W2,PRTLINE+9   RESET LINE POINTER
UNPKGP   EQU   *
         UNPK  DBW(9),0(5,W1)      UNPACK BUFFER TO WORK AREA
         TR    DBW(8),DMPTRNS-X'F0'  CONVERT HEX TO DISPLAY
         MVC   0(8,W2),DBW         MOVE 8 BYTES TO PRINT LINE
         SPACE 1
         LA    W1,4(0,W1)     BUMP BUFFER POINTER & LINE POINTER
         LA    W2,10(0,W2)
         SPACE 1
         C     W2,ENDLINE     END OF LINE ?
         BNL   PRTOUTL        YES
         SPACE 1
TSTENDB2 EQU   *
         C     W1,ENDBUF      END OF BUFFER ?
         BL    UNPKGP         NO
         EJECT
*---------------------------------------------------------------------*
*        OUTPUT THE LINE
*---------------------------------------------------------------------*
PRTOUTL  EQU   *
         TM    FLG,PRINTF     PRINT OPTION ?
         BO    PRINOPTN       YES
         SPACE 1
         C     W1,ENDBUF      END OF BUF ?
         BL    PRTSTUP        NO ?
         SPACE 1
BLKDSL   EQU   *
         LR    V,W1
         S     V,ENDBUF   COMPUT NO. BYTES OVERRUN * 2
         SLL   V,1
         ST    V,DBW
         LR    V,W2       CURRENT LINE POSITION
         S     V,DBW      SUBTRACT OVER RUN
         SH    V,=H'2'        SUBTRACT 2 BLANKS
         L     PRTAD,ENDLINE
         SR    PRTAD,V             GET COUNT
         BM    PRTSTUP
         MVI   0(V),C' '           BLANK REMAINDER OF LINE
         EX    PRTAD,DSPBLK
         SPACE 2
PRTSTUP  EQU   *
         MVC   DBW(6),=X'F02020202020'
         ED    DBW(6),LINEAD+1          SET LINE ADDR INTO PRINT LINE
         OI    DBW+5,X'F0'
         MVC   PRTLINE+1(4),DBW+2
         SPACE 1
         AP    LINEAD(4),LINEADIN(2)    BUMP LINE ADDR
         BAL   SL,LIST        PRINT LINE
         SPACE 2
         C     W1,ENDBUF      END OF BUFFER ?
         BL    RESTRTLN       NO
         SPACE 3
DSPRET   EQU   *
         MVI   LISTNOP+1,0
         L     SL,DSPRSV
         BR    SL             RETURN
         EJECT
PRINOPTN EQU   *
         LR    V,W1
         S     V,BEGBLN       COMPUTE PRINT BYTE COUNT
         BCTR  V,0
         L     PRTAD,BEGBLN
         EX    V,PRTMV2       MOVE DATA TO PRINT LINE
         EX    V,PRTTRN       TRANSLATE NON-DISPLAY TO PERIODS
         SPACE 1
         MVI   PRTLINE+PTE-33,C'*'
         MVI   PRTLINE+PTE,C'*'
         SPACE 1
         C     W1,ENDBUF      END OF BUFFER ?
         BL    PRTSTUP        NO
         SPACE 2
         L     PRTAD,BEGBLN
         AH    PRTAD,BUFINC
         SR    PRTAD,W1
         LR    V,W1
         S     V,ENDBUF
         AR    V,PRTAD
         LA    PRTAD,PRTLINE+PTE
         MVI   0(PRTAD),C' '    BLANK END SYMBOL
         SR    PRTAD,V
         MVI   0(PRTAD),C' '
         EX    V,PRTBLK4        BLANK PRINT OVERFLOW
         LTR   V,V
         BNZ   *+6
         BCTR  PRTAD,0
         MVI   0(PRTAD),C'*'
         B     BLKDSL
         EJECT
*---------------------------------------------------------------------*
*        CONSTANTS
*---------------------------------------------------------------------*
TITLE    DS    0CL70
         DC    CL40'              ***** DUMP OF TAPE NUMBER '
NUMBER   DC    CL7' '
         DC    CL23'*****                  '
TIME     DC    CL20'    '
DATE     DC    CL20'    '
PAGE     DC    CL25'PAGE   '
PGCT     DC    PL2'+0'
NOMCC    DC    C' FILES=1,REC=ALL,SKPFIL=0,SKPREC=0,PRINT=YES,REDUN=NO'
BUC      DS    CL12
         DS    CL30
BSV      DS    CL12
DGEREOJ  DC    C'JOB CANCELLED DUE TO CONTROL CARD ERROR'
REDUNM   DC    C' ** RECORD BELOW WAS REDUNDENT **'
REDCC    DC    C'  CC=00'
BADCCM   DC    C'**** ABOVE CONTROL CARD IS IN ERROR ****'
REDEOJ   DC    C'JOB CANCELLED DUE TO 10 REDUNDENT RECORDS'
RECHDR   DC    C'  RECORD 00000    FILE 000    00000 BYTES '
EOFMSG   DC    C'*** END OF FILE ***'
DBW      DS    D
         DS    CL2
TAPERSV  DS    F
DSPRSV   DS    F
LNCT     DC    PL2'+98'
LNMAX    DC    PL2'+54'
LISTMOVE MVC   PRTLINE+1(0),0(PRTAD)
PRTCODE  DC    X'09'
CONVBPK  PACK  DBW(8),BUC(0)
ENDBUF   DS    F
LINEAD   DS    F
ENDLINE  DS    F
LINEADIN DS    H
BEGBLN   DS    F
BYTECT   DS    H
BUFINC   DS    H
DMPTRNS  DC    C'0123456789ABCDEF'
DSPBLK   MVC   1(0,V),0(V)
PRTMV2   MVC   PRTLINE+99(0),0(PRTAD)
PRTTRN   TR    PRTLINE+99(0),PRTTRANS
PRTBLK4  MVC   1(0,PRTAD),0(PRTAD)
         EJECT
MYSAVE   DC    18F'0'
REDCT    DS    H                        REDUNDENT COUNT
FILENO   DS    H                        CURRENT FILE NO.
FILESKCT DS    H                        FILE SKIP COUNT
RECNO    DS    F                        CURRENT REC NO.
RECSKCT  DS    H                        RECORD SKIP COUNT
RECCT    DS    H                        NUMBER OF RECS TO BE DUMPED
FILECT   DS    H                        NUMBER OF FILES TO BE DUMPED
BUF      DS    F         BUFFER ADDR
SAVERCT  DS    H
FLG      DC    X'00'     FLAG BYTE
FIRSTCC  EQU   X'80'     FIRST CONTROL CARD FOUND
PRINTF   EQU   X'40'
RUNF     EQU   X'20'
REDUNF   EQU   X'10'
         SPACE 1
NOMINFLG DC    X'40'     NOMINAL FLG SETTING
         SPACE 3
*-------------------------------------------------------------------*
PRTTRANS EQU   *
         DC    256CL1' '
PRTTRNED EQU   *
         ORG   PRTTRANS+X'81'
         DC    C'ABCDEFGHI'
         ORG   PRTTRANS+X'91'
         DC    C'JKLMNOPQR'
         ORG   PRTTRANS+X'A2'
         DC    C'STUVWXYZ'
         ORG   PRTTRANS+X'B0'
         DC    C'0123456789'
         ORG   PRTTRANS+C'A'
         DC    C'ABCDEFGHI'
         ORG   PRTTRANS+C'J'
         DC    C'JKLMNOPQR'
         ORG   PRTTRANS+C'S'
         DC    C'STUVWXYZ'
         ORG   PRTTRANS+C'0'
         DC    C'0123456789'
         ORG   PRTTRANS+C' '
         DC    C' '
         ORG   PRTTRNED
*-------------------------------------------------------------------*
         SPACE 3
         EJECT
TAPEECB  DC    F'0'
         SPACE 2
         DS    0D
TAPEIOB  EQU   *
         DC    F'0'
ECBAD    DC    A(TAPEECB)
CSW      DC    2F'0'
CCWAD    DC    A(CCWMODE)
DCBAD    DC    A(FILE)
         DC    2F'0'
         SPACE 2
CCWMODE  CCW   3,0,X'60',1    SET MODE
CCW      CCW   0,0,X'20',25000
         EJECT
SYSIN    DCB   DDNAME=SYSIN,EODAD=CCEOF,MACRF=GM,DSORG=PS,LRECL=80
         SPACE 2
FILE     DCB   DDNAME=FILE,MACRF=(E),DSORG=PS,IOBAD=TAPEIOB,           X
               EODAD=TAPEEOF,EXLST=MYJFCB
MYJFCB   DC    X'87'
         DC    AL3(JFCB)
JFCB     DC    44F'0'
         SPACE 2
SYSPRINT DCB   DDNAME=SYSPRINT,MACRF=PM,RECFM=FM,DSORG=PS,LRECL=133,   X
               BLKSIZE=133
         SPACE 4
CARDCTL  DC    X'19'
CARD     DC    CL80' '
PRTLINE  DS    CL133
         DS    CL8
         LTORG
         SPACE 1
HEXTRT   DC    X'FAFBFCFDFEFF'
         DC    XL41'00'
         DC    C'0123456789'
         SPACE 3
         DCBD  DSORG=PS
         END
//LKED.SYSLMOD DD DSN=SYS2.LINKLIB,DISP=SHR                             00080000
//LKED.SYSIN DD *                                                       00090000
 SETCODE AC(1)                                                          00100000
 NAME ZDUMPTP(R)                                                        00110000
//                                                                      00120000
