//PDSPRINT  JOB (TSO),
//             'Install PDSPRINT',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//* ********************************************************            00020000
//* *  INSTALL THE 'PDSPRINT' PROGRAM                      *            00030000
//* ********************************************************            00040000
//PDSPRINT EXEC ASMFCL,COND=(0,NE)                                      00050000
//SYSIN    DD *                                                         00060000
         TITLE 'PDS PRINT PROGRAM WITH LINE-COUNT OF 60/PAGE'
         PRINT ON,NOGEN
*---------------------------------------------------------------------*
*
*        PDSPRINT WILL PRINT OF PUNCH, IN ALPHABETICAL ORDER, ALL OR
*        OR SELECTED MEMBER OF A SOURCE PDS (LRECL=80). TO PRINT OR
*        PUNCH ALL MEMBERS:
*
*        //DOIT     EXEC PGM=PDSPRINT,PARM=X       PARM OPTIONAL)
*        //SYSPRINT  DD  SYSOUT=A                  (MSG DATA SET)
*        //SYSUT1    DD  DSN=XXXXXXXX,DISP=SHR     (SOURCE LIBRARY)
*        //SYSUT2    DD  SYSOUT=X                  (OUTPUT DATASET)
*
*        PDSPRINT - THIS PROGRAM
*        SYSPRINT - MESSAGES PRODUCED BY PGM
*        SYSUT1   - PDS TO BE PROCESSED
*        SYSUT2   - OUTPUT SEQUENTIAL DATASET
*        SYSIN    - OPTIONAL (SEE BELOW)
*
*        PARM=(OPTIONAL)
*
*            PRINT OR A  - SEQUENTIAL DATASET WITH FORMATTED OUTPUT TO
*                          INCLUDE PAGE TITLES & MEMBERNAME SUBTITLES
*            PUNCH OR B  - SEQUENTIAL DATASET WITH IEBUPDTE ./ ADD
*                          CARD PRECEDING EACH MEMBER.
*            NULL        - DEFAULT TO PRINT MODE
*
*        SELECTION CRITERIA:
*
*        TWO FORMS OF MEMBER SELECTION ARE POSSIBLE. IN EITHER CASE,
*        PARM INFO IS IGNORED AND A //SYSIN DATASET MUST BE PROVIDED
*        CONTAINING ONE OR MORE CONTROL CARDS OF THE FORM
*
*        OPERATION  SELECTMODE=LIST
*
*        OPERATION IS EITHER PRINT OR PUNCH AND IS PRECEDED AND
*        FOLLOWED BY ATLEAST ONE BLANK. PRINT AND PUNCH REQUESTS MAY
*        NOT BE MIXED IN THE SAME JOB STEP.  LIST IS A LIST OF ONE OR
*        MORE 1-8 A/N CHARACTER STRINGS (MEMBERNAMES). IF MORE THAN
*        ONE STRING IS LISTED, THEY MUST BE SEPARATED BY COMMAS WITH
*        NO INTERVENING BLANKS AND THE WHOLE STRING MUST BE ENCLOSED IN
*        PARENTHESES.  LISTS EXTENDING BEYOND COL 71 MUST BE CONTINUED
*        BY BREAKING AT A COMMA BEFORE COL 72 AND RESUMING WITH THE
*        NEXT ENTRY ANYWHERE BEFORE COL 72 OF THE NEXT CARD. THE
*        INTERPRETATION OF THE LIST DEPENDS ON SELECTMODE.  IF
*        SELECTMODE IS MEMBER, THE LIST IS SIMPLY A LIST OF MEMBERS
*        TO BE PROCESSED (ACCORDING TO OPERATION). IF SELECTMODE IS
*        SCAN, THEN THE ENTIRE PDS DIRECTORY IS SCANNED FOR MEMBERS
*        WHOSE NAMES BEGIN WITH THE SAME CHARACTER STRING AS ONE OF
*        THE STRINGS IN THE LIST. THUS, IF SYSUT1 SPECIFIES
*        'SYS1.PROCLIB', THEN  MEMBER=FORTHC SELECTS THE ONE MEMBER
*        FORTHC.  BUT  SCAN=FORTHC  MAY SELECT MEMBERS FORTHC,
*        FORTHCG, FORTHCL, AND FORTHCLG.
*
*        EXAMPLES:
*
*        PRINT MEMBER=(ASMHC,ASMHCL)
*
*        PRINT SCAN=(PLI)
*
*        PUNCH MEMBER=(MEMBER1,MEMBER2,MEMBER3,MEMBER5,MEMBER6,
*                MEMBER7,MEMBER9)
*
*
* CHNGE LOG: 30JUN90 - CLEANED, SCRUBBED, AND RINSED THE CODE  JDM
*                      TOO MANY CHANGES TO MARK.
*             1JUL90 - CHANGED FROM 120 LINES INITIAL LINE CT TO
*                      60, WAY IT WAS LONG AGO.                JDM1
*            26FEB02 - COMMENT AMODE/RMODE FOR MVS 3.8            *JLM*
*---------------------------------------------------------------------*
R0       EQU   0
R1       EQU   1
R2       EQU   2
R3       EQU   3                       FIRST BASE REGISTER
R4       EQU   4                       SECOND BASE REGISTER
R5       EQU   5
R6       EQU   6
R7       EQU   7                  STORAGE BUFFER ADDR
R8       EQU   8
R9       EQU   9
R10      EQU   10
R11      EQU   11
R12      EQU   12                      IHADCB BASE / LINKAGE REGISTER
R13      EQU   13
R14      EQU   14
R15      EQU   15
         SPACE
* PDSPRINT AMODE 24                                               *JLM*
* PDSPRINT RMODE 24                                               *JLM*
PDSPRINT CSECT
         SAVE  (14,12),,PDSPRINT_&SYSDATE._&SYSTIME
         USING PDSPRINT,R3,R4
         LR    R3,R15
         LA    R4,4095(,R3)        LOAD SECOND
         LA    R4,1(R4)            BASE REGISTER
         ST    R13,SAVEAREA+4
         LR    R12,R13
         LA    R13,SAVEAREA
         ST    R13,8(R12)
         L     R5,0(R1)            SAVE A(PARM)
         RDJFCB (LIBDCB)           READ JFCB
         OPEN  (LIBDCB,,PDSDCB,,OUTDCB,(OUTPUT),MESSAGES,(OUTPUT))
         PUT   MESSAGES,PDSUTIL    WRITE SYSPRINT HEADING
         LA    R12,PDSDCB          LOAD PDSDCB ADDR
         USING IHADCB,R12
         MVC   PDSBLKSI,DCBBLKSI   SAVE BLOCKSIZE AND
         LH    R0,DCBBLKSI         LOAD IN REGISTER 0
         GETMAIN R,LV=(0)          GET STORAGE FOR INPUT AREA
         LR    R7,R1               SAVE ADDRESS OF STORAGE AREA
         L     R2,16               LOAD CVT ADDR
         L     R6,0(R2)            LOAD ADDR OF CVT DOUBLEWORD
         L     R6,4(R6)            LOAD ADDR OF CURRENT TCB
         L     R6,12(R6)           LOAD ADDR OF TIOT
         LA    R6,24(R6)           LOAD ADDR OF FIRST DD ENTRY
         XR    R8,R8               ZERO REG AND
NXTENTRY EQU   *
         IC    R8,0(R6)            INSERT LENGTH OF DD ENTRY
         CLC   4(5,R6),=C'SYSIN'   COMPARE FOR SYSIN
         BE    RDSYSIN               AND BRANCH ON EQUAL
         AR    R6,R8                 DD ENTRY
         CLC   0(4,R6),=F'0'       COMPARE FOR END OF TIOT
         BNE   NXTENTRY            BRANCH IF NOT END
         LA    R12,NEXTBLK         RETURN ADDR FOR BUILD HEADER PROC
         CLC   0(2,R5),=F'0'       CHECK PARM LENGTH
         BE    PRNTMODE            NO PARM, DEFAULT TO PRINT MODE
         CLI   2(R5),C'A'          PARM=A
         BE    PRNTMODE            YEP
         CLI   2(R5),C'B'          PARM=B
         BE    PNCHMODE            YEP
         CLC   2(5,R5),=C'PRINT '  PARM=PRINT
         BE    PRNTMODE            YEP
         CLC   2(5,R5),=C'PUNCH '  PARM=PUNCH
         BE    PNCHMODE            YEP
         MVC   BADPARM+27(5),2(R5)   MOVE BAD PARM INTO MSG
         PUT   MESSAGES,BADPARM      AND WRITE IT
PRNTMODE EQU   *
         PUT   MESSAGES,PRINTALL   PRINT ALL SELECTED
         B     PRNTHEAD            GO BUILD PRINT HEADER
PNCHMODE EQU   *
         PUT   MESSAGES,PUNCHALL   PUNCH ALL SELECTED
         B     PNCHHEAD            GO BUILD PUNCH HEADER
         SPACE
*---------------------------------------------------------------------*
*        READ A DIRECTORY BLOCK USING BSAM
*---------------------------------------------------------------------*
         SPACE
NEXTBLK  EQU   *
         READ  LIBECB,SF,LIBDCB,WORKAREA
         CHECK LIBECB
         XC    LIBECB,LIBECB       ZERO OUT ECB
         LA    R9,WORKAREA+10      LOAD ADDR OF WORKAREA
         SPACE
*---------------------------------------------------------------------*
*        BUMP THROUGH THE DIRECTORY BLOCK TO GET MEMBER NAMES AND
*        TTR'S FOR  BPAM READ (USED FOR 'ALL' OR SCAN PROCESSING ONLY)
*---------------------------------------------------------------------*
         SPACE
MOVEON   EQU   *
         CLC   0(8,R9),HEXFF       IF ENTRIES ALL F'S, BRANCH
         BE    EOJ                 FOR LAST BLOCK, OTHERWISE
         LH    R6,10(R9)           LOAD TTRC
B1       B     MVHEADNG            B  IF 'ALL' MODE (USE ALL ENTRIES)
NOP4     NOP   COMPSCN2            B  AFTER FIND RIGHT DIR BLOCK (SCAN
COMPSCN1 CLC   SCANCHAR(0),WORKAREA COMPARE TO DIR BLK'S KEY
         BH    NEXTBLK
         EX    0,COMPSCN2
         BH    NEXTMEMB
         BL    NOMATCH
         OI    NOP4+1,X'F0'
         B     MVHEADNG
         SPACE
NOMATCH  EQU   *
         MVC   NOSCAN+35(8),SCANCHAR
         PUT   MESSAGES,NOSCAN
         B     EOJ1
         SPACE
COMPSCN2 EQU   *
         CLC   SCANCHAR(0),0(R9)   COMPARE TO NEXT DIR BLK ENTRY
         BNE   EOJ1
         SPACE
MVHEADNG EQU   *
         MVC   HEADING2+21(8),0(R9)    MOVE NAME TO HEADING
         CLI   MODE,C'B'           BRANCH IF PUNCH
         BE    PUTHDNG2
         CL    R5,=F'10'           IF LINE COUNT IS
         BNL   SKIP2                  LESS THAN 9
         AP    PAGECNT,=P'1'       BUMP THE PAGE COUNT
         OI    PAGECNT+1,X'0F'     AND WRITE
         UNPK  PAGE+5(3),PAGECNT   THE HEADING FOR
         PUT   OUTDCB,HEADING1     A NEW PAGE
         LA    R5,60               LINES PER PAGE                JDM1
SKIP2    EQU   *
         SH    R5,=H'4'            DECREMENT LINE COUNT
         MVI   PDSAREA1,C'0'       MOVE IN CONTROL CHARACTER
PUTHDNG2 EQU   *
         PUT   OUTDCB,HEADING2     WRITE HEADING
         MVI   11(R9),X'00'        THEN ZERO OUT THE C
         MVC   TTRC(4),8(9)
         POINT PDSDCB,TTRC
         SPACE
*---------------------------------------------------------------------*
*        READ THE MEMBER USING BPAM
*---------------------------------------------------------------------*
         SPACE
NEXTREC  EQU   *
         READ  PDSECB,SF,PDSDCB,(R7)     READ A BLOCK OF DATA
         CHECK PDSECB
         SPACE
*---------------------------------------------------------------------*
*  DEBLOCK INTO 80 CHARACTER RECORDS AND WRITE THEM OUT
*---------------------------------------------------------------------*
         SPACE
         OI    EOJ+1,X'F0'
         L     R2,PDSECB+16        LOAD ADDR OF IOB
         LH    R11,PDSBLKSI        LOAD BLOCKSIZE
         SH    R11,14(R2)          SUBTRACT RESIDUAL COUNT FROM
         LA    R11,0(R7,R11)       BLOCKSIZE AND CALCULATE ADDR
         BCTR  R11,0                 OF LAST BYTE OF BLOCK
         LA    R10,80              RECORD LENGTH FOR LOOP THRU BLK
         XC    PDSECB,PDSECB       ZERO OUT ECB
         LR    R8,R7               LOAD INPUT AREA ADDR
         CLI   MODE,C'B'           CHECK IF PUNCH MODE
         BE    PNCHRCD             YEP, LIFE IS SIMPLER
         SPACE
MOVEREC  EQU   *
         MVC   PDSAREA2(80),0(R8)  MOVE RECORD TO OUTPUT AREA
         BCT   R5,PRNTRCD          LINE COUNT - 1, BRANCH UNLESS 0
         AP    PAGECNT,=P'1'       BUMP PAGE COUNT
         OI    PAGECNT+1,X'0F'     AND SKIP
         UNPK  PAGE+5(3),PAGECNT   TO A NEW PAGE
         PUT   OUTDCB,HEADING1     AND WRITE A NEW HEADING
         MVC   HEADING2+30(11),=C'(CONTINUED)'  WRITE NAME HEADING
         PUT   OUTDCB,HEADING2           WITH CONTINUATION INDICATED
         MVC   HEADING2+30(11),BLANKS   CLEAR HEADING
         LA    R5,55                   RESET LINE COUNT (61-1-4-1)
         MVI   PDSAREA1,C'0'       MOVE IN CONTROL CHARACTER
PRNTRCD  EQU   *
         PUT   OUTDCB,PDSAREA1     WRITE OUTPUT RECORD
         MVI   PDSAREA1,C' '       BLANK CC CHAR
         BXLE  R8,R10,MOVEREC      LOOP THRU ALL RCDS IN BLOCK
         B     NEXTREC             GO READ NEXT BLOCK WHEN DONE
         SPACE
PNCHRCD  EQU   *
         PUT   OUTDCB,(R8)         WRITE OUTPUT RCD
         BXLE  R8,R10,PNCHRCD      LOOP THRU ALL RCDS IN BLOCK
         B     NEXTREC             GO READ NEXT BLOCK WHEN DONE
         SPACE
*---------------------------------------------------------------------*
*        END OF DATA ROUTINE FOR BPAM READ
*        ADVANCE POINTER TO NEXT MEMBER NAME IN DIRECTORY BLOCK
*---------------------------------------------------------------------*
         SPACE
NEXTMEMB EQU   *
         CLC   WORKAREA(8),0(R9)   IF LAST ENTRY IN BLOCK
         BE    NEXTBLK             BRANCH,
         N     R6,=X'0000001F'     OTHERWISE ZERO OUT ALL BUT THE
         AR    R6,R6               NUMBER OF USER
         LA    R9,12(R6,R9)        HALFWORDS & BUMP ENTRY ADDR
         B     MOVEON              PROCESS NEXT ENTRY
         SPACE
*---------------------------------------------------------------------*
*        READ CONTROL CARDS
*---------------------------------------------------------------------*
         SPACE
RDSYSIN  EQU   *
         OPEN  CARDIN              OPEN SYSIN
NEXTCARD EQU   *
         LA    R12,CARDIN          ESTABLISH ADDRESSABILITY
         LA    R8,PUNT             LOAD &
         ST    R8,DCBEODAD          STORE EODAD
         GET   CARDIN,CARD         AND READ A CONTROL CARD
         LA    R8,INVALDCD         LOAD &
         ST    R8,DCBEODAD          STORE EODAD
         LA    R8,CARD             LOAD ADDR OF INPUT RECORD
         LA    R9,CARD+71          LOAD ADDR OF COL 72
         MVI   MESSAGE,C'-'
         PUT   MESSAGES,MESSAGE    PRINT CARD
         CLI   0(R8),C' '          IF NO NAME FIELD
         BE    TRT1                BRANCH TO FIND OPERATION FIELD
         TRT   1(70,R8),BLANKLIM   ELSE FIND END OF NAME FIELD
         BZ    INVALDCD            WRITE ERROR IF NOT FOUND
         LR    R8,R1               ELSE DETERMINE
         LR    R10,R9              HOW MANY CHARACTERS
         SR    R10,R8              ARE LEFT ON
         BCTR  R10,0    (SUB 1)    INPUT RECORD AND
         EX    R10,TRT2            FIND OPERATION FIELD
         BZ    INVALDCD            WRITE ERROR IF NOT FOUND
OPFIELD  EQU   *
         LR    R8,R1               ELSE COMPARE
         STM   8,9,REG8            SAVE REGISTERS
         CLI   MODE,0              HAS PRNT/PNCH MODE BEEN SET
         BNE   CHKOP               YES, GO SEE IF OP MATCHES MODE
         LA    R12,FINDMEMS        LOAD RETURN ADDR FROM SETUP
         CLC   0(6,R8),=C'PRINT '  IS IT PRINT
         BE    PRNTHEAD            YEP, GO SET UP FOR PRINT
         CLC   0(6,R8),=C'PUNCH '  IS IT PUNCH
         BE    PNCHHEAD            YEP, GO SET UP FOR PUNCH
         B     PUTOPER1
         SPACE
CHKOP    EQU   *
         CLI   MODE,C'A'           ARE WE IN PRINT MODE
         BNE   TESTPNCH            NO, WE'RE IN PUNCH MODE
         CLC   0(6,R8),=C'PRINT '  WRITE ERROR
         BE    FINDMEMS            MESSAGE IF
         B     PUTOPER1            OTHERWISE
         SPACE
TESTPNCH EQU   *
         CLC   0(6,R8),=C'PUNCH '  ESTABLISH
         BNE   PUTOPER1            THE APPROPRIATE
FINDMEMS EQU   *
         LM    R8,R9,REG8          RESTORE REGISTERS
         LA    R8,6(R8)            SEARCH INPUT
         LR    R10,R9              FOR OPERAND
         SR    R10,R8              FIELD
         BCTR  R10,0    (SUB 1)    WRITE ERROR MESSAGE
         EX    R10,TRT2            IF NOT FOUND
         BZ    INVALDCD            BY COLUMN 72
         LR    R8,R1               CHECK FOR
         CLC   0(6,R8),SCAN
         BE    MULTISCN
         CLC   0(5,R8),SCAN
         BE    SCANPROC
         CLC   0(8,R8),MEMBER
         BE    MULTIMEM            AND BRANCH TO PROCESS
         CLC   0(7,R8),MEMBER
         BNE   PUTOPER2            WRITE ERROR MESSAGE IF NOT
         CLI   7(R8),C' '          CHECK FOR NAME
         BE    INVALDCD            BRANCH IF NONE
         LA    R8,7(R8)            OTHERWISE DETERMINE
         LR    R10,R9              HOW MANY
         SR    R10,R8              CHARACTERS ARE
         CL    R10,=F'8'           LEFT BEFORE
         BH    COMP8               COLUMN 72
         BCTR  R10,0    (SUB 1)    TEST FOR END OF
EXTRT3   EQU   *
         EX    R10,TRT3            NAME FIELD
         BZ    INVALDNM            WRITE ERROR IF NAME TOO LONG
         LR    R10,R1              DETERMINE MEMBER
         SR    R10,R8              NAME LENGTH
         BCTR  R10,0    (SUB 1)    AND MOVE NAME
         EX    R10,MOVENAME        TO NAMELIST
         FIND  PDSDCB,NAMELIST,D   AND ISSUE FIND
         L     R11,FINDBR(R15)     LOAD ADDR BRANCH
         BR    R11                 ADDR & BRANCH
         SPACE
FOUND    EQU   *
         LA    R12,PDSDCB          ESTABLISH ADDRESSABILITY
         LA    R11,EOJ             FOR PDSDCB AND ALTER
         ST    R11,DCBEODAD        END OF DATA ADDRESS
         MVC   HEADING2+21(8),NAMELIST MOVE NAME TO HEADING
         CLI   MODE,C'B'               TEST FOR OUTPUT MODE
         BE    PUTHEAD2            BRANCH FOR PUNCHED OUTPUT
         AP    PAGECNT,=P'1'       BUMP PAGE COUNT
         OI    PAGECNT+1,X'0F'     UNPACK PAGE COUNT
         UNPK  PAGE+5(3),PAGECNT   INTO HEADING
         PUT   OUTDCB,HEADING1     PRINT HEADING
PUTHEAD2 EQU   *
         PUT   OUTDCB,HEADING2     WRITE MEMBER NAME
         LA    R5,56               SET LINE CT
         B     NEXTREC             BRANCH TO PROCESS MEMBER
         SPACE
COMP8    EQU   *
         LA    R10,8               LOAD NAME LENGTH
         B     EXTRT3              BRANCH TO TEST
         SPACE
FINDBR   DC    A(FOUND,PUTNOMEM,IOERROR1)
         SPACE
SCANPROC DS    0H
         NI    B1+1,X'0F'
         LA    R8,5(R8)
         TRT   0(9,R8),BLANKLIM
         BZ    INVLDSCN
         SR    R1,R8
         BCTR  R1,0    (SUB 1)
         STC   R1,COMPSCN1+1
         STC   R1,COMPSCN2+1
         EX    R1,MOVESCAN
         LA    R12,1
         XR    R5,R5
         B     NEXTBLK
         SPACE
*---------------------------------------------------------------------*
*        PROCESS MULTIPLE MEMBERS ON CONTROL CARD
*---------------------------------------------------------------------*
         SPACE
MULTIMEM EQU   *
         LA    R8,8(R8)
         BAL   R12,BUILDTBL
         STH   R7,16(R5)
         BLDL  PDSDCB,16(R5)
         C     R15,=F'8'
         BNE   ALTEREOJ
         LA    R10,IOERROR3
         BAL   R12,PUTMESSG
         B     PUNT
         SPACE
ALTEREOJ EQU   *
         LA    R12,PDSDCB
         LA    R10,NEXTBLDL
         ST    R10,DCBEODAD
         LR    R6,R7
         L     R7,REG7
         LA    R9,20(R5)
         XR    R5,R5
         B     NEXTBLDL+4
         SPACE
NEXTBLDL EQU   *
         LA    R9,12(R9)
         SH    R6,=H'1'
         BM    CLOSEIT
         CLI   10(R9),X'00'
         BNE   MVHEADNG
         MVC   NOMEMBER+9(8),0(R9)
         LA    R10,NOMEMBER
         BAL   R12,PUTMESSG
         B     NEXTBLDL
         SPACE
MULTISCN EQU   *
         NI    B1+1,X'0F'
         LA    R8,6(R8)
         BAL   R12,BUILDTBL
         LR    R12,R7
         L     R7,REG7
         LA    R8,8(R5)
         ST    R8,REG8
         XR    R5,R5
NEXTSCAN EQU   *
         L     R8,REG8
         LA    R8,12(R8)
         ST    R8,REG8
         TRT   0(9,R8),BLANKLIM
         BZ    FULLNAME
         SR    R1,R8
         BCTR  R1,0    (SUB 1)
EXEC1    EQU   *
         MVC   SCANCHAR,BLANKS
         EX    R1,MOVESCAN
         STC   R1,COMPSCN1+1
         STC   R1,COMPSCN2+1
         NI    NOP4+1,X'0F'        NOP ALLOWS SEARCH OF DIR BLKS
NOP6     NOP   NOP4                B  AFTER 1ST TIME (DIR BLK FND)
         OI    NOP6+1,X'F0'
         B     NEXTBLK             GO READ 1ST DIR BLOCK
         SPACE
FULLNAME EQU   *
         LA    R1,7
         B     EXEC1
         SPACE
BUILDTBL EQU   *
         ST    R12,REG12
         ST    R7,REG7
         L     R5,BLDLADR
         LTR   R5,R5
         BNZ   INITBLDL
         GETMAIN R,LV=1600,SP=1
         LR    R5,R1
         ST    R5,BLDLADR
INITBLDL EQU   *
         LA    R6,8(R5)
         ST    R6,0(R5)           A(8(R5))     0  A(1ST ENTRY)-12
         ST    R6,8(R5)           A(8(R5))     8  A(NXT AVAIL SLOT)
         LA    R6,1220(R5)
         ST    R6,4(R5)           A(1220(R5))  4  A(END OF TABLE)
         XR    R7,R7
         ST    R7,12(R5)          0           12  NO. ENTRIES
         LA    R6,12
         ST    R6,16(R5)          12          16  ENTRY LENGTH
NEWMEMBR EQU   *
         CLI   0(R8),C' '
         BE    CONTINUE
         XR    R2,R2
         TRT   0(9,R8),TABLE1    LOOK FOR ) OR ,
         CR    R8,R1
         BE    INVALDCD
         LA    R9,1(R1)
         SR    R1,R8
         BCTR  R1,0    (SUB 1)
         B     *+4(R2)
         B     INVALDNM
         B     MOVENTRY          FOUND ,
         MVC   ENTRY(8),BLANKS   FOUND )
         EX    R1,MOVELIST
         L     R12,REG12
         B     BUILDLST
MOVENTRY EQU   *
         MVC   ENTRY(8),BLANKS
         EX    R1,MOVELIST
         LR    R8,R9
         LA    R12,NEWMEMBR
BUILDLST EQU   *
         L     R11,0(R5)
         L     R10,8(R5)
         LA    R9,12(R10)
         MVC   0(8,R9),HEXFF
NEXTENTY EQU   *
         LA    R11,12(R11)
         CLC   0(8,R11),ENTRY
         BL    NEXTENTY
         BE    0(R12)
COMPREGS EQU   *
         CR    R10,R11
         BL    SAVENTRY
         MVC   12(12,R10),0(R10)
         SH    R10,=H'12'
         B     COMPREGS
         SPACE
SAVENTRY EQU   *
         MVC   0(12,R11),ENTRY
         LA    R7,1(R7)
         ST    R9,8(R5)
         CLC   4(4,R5),8(R5)
         BNE   0(R12)
         LA    R10,MANYMEMB
         L     R12,REG12
         B     PUTMESSG
         SPACE
CONTINUE EQU   *
         GET   CARDIN,CARD
         MVI   MESSAGE,C' '
         PUT   MESSAGES,MESSAGE
         TRT   CARD(71),NONBLANK   FIND 1ST NONBLANK CHAR ON CARD
         BZ    INVALDCD            BLANK CARD
         LR    R8,R1               ADDR OF NEXT FIELD
         B     NEWMEMBR
         SPACE
EOJ1     EQU   *
         BCT   R12,NEXTSCAN
         B     CLOSEIT
         SPACE
PUTMESSG EQU   *
         PUT   MESSAGES,(10)
         BR    R12
BLDLADR  DC    F'0'
REG7     DS    F
HEXFF    DC    8X'FF'
TABLE1   DC    93X'00',X'08',13X'00',X'04',148X'00'     ) AND ,
ENTRY    DC    CL12' '
MOVELIST MVC   ENTRY(0),0(R8)
MANYMEMB DC    CL133'0 TOO MANY MEMBERS SPECIFIED. NO FURTHER ENTRIES W*
               ILL BE PROCESSED.'
IOERROR3 DC    CL133'0 A PERMANENT I/O ERROR OCCURRED WHEN BLDL WAS ISS-
               UED. PROCESSING HALTED.'
         SPACE
*---------------------------------------------------------------------*
*        ESTABLISH HEADING FOR PRINTED OUTPUT
*---------------------------------------------------------------------*
         SPACE
PRNTHEAD DS    0H
         MVI   MODE,C'A'           SET MODE TO PRINT
         MVC   DSNVOL(44),JFCB     MOVE DSN INTO HEADER LINE
         TRT   DSNVOL(45),BLANKLIM GET A(1ST BLANK) INTO R1
         L     R2,16               LOAD CVT ADDR
         L     R6,196(R2)          LOAD ADDR OF SMCA
         CLC   16(4,R6),=C'3032'   IS SYSTEM ID '3032'
         BNE   TEST360             NO, GO CHECK IF 360
         MVC   2(L'TS,R1),TS       MOVE IN TS VOLSER LINE
         LA    R8,L'TS+3(R1)       GET ADDR FOR VOLSER
         B     MOVSERNO            GO MOVE IN VOLSER
TEST360  EQU   *
         CLC   16(4,R6),=C'0175'   IS SYSTEM ID '0175'
         BNE   STNDHEAD            NO, USE STANDARD VOLSER LINE
         MVC   2(L'UNC,R1),UNC     MOVE IN UNCL VOLSER LINE
         LA    R8,L'UNC+3(R1)      GET ADDR FOR VOLSER
         B     MOVSERNO            GO MOVE IN VOLSER
         SPACE
STNDHEAD EQU   *
         MVC   2(L'VOLSER,R1),VOLSER   MOVE IN DEFAULT VOLSER LINE
         LA    R8,L'VOLSER+3(R1)   GET ADDR FOR VOLSER
MOVSERNO EQU   *
         MVC   0(6,R8),JFCB+118    MOVE IN VOLSER NUMBER
         TIME  DEC
         ST    R1,DATETIME         SAVE DATE
         ST    R0,DATETIME+4       SAVE TIME
         MVI   YEAR+7,X'0F'        SET UP YEAR
         MVO   YEAR+6(2),DATETIME+1(1)  FOR UNPACKING
         UNPK  DATE+7(2),YEAR+6(2) INTO HEADING
         CVB   R9,YEAR             CONVERT YEAR TO
         STC   R9,YEAR             BINARY AND
         TM    YEAR,X'03'          TEST FOR LEAP YEAR
         BZ    LEAPYEAR            BRANCH FOR LEAP YEAR
         LA    R10,DAYS            LOAD ADDR OF DAYS
         B     LOADMNTH            BRANCH TO LOAD MONTHS
         SPACE
LEAPYEAR EQU   *
         LA    R10,DAYS+2          LOAD ADDR OF DAYS FOR LEAP YEAR
LOADMNTH EQU   *
         LA    R11,MONTHS          LOAD ADDR OF MONTHS
NXTMONTH EQU   *
         LA    R10,4(R10)          BUMP ADDR OF DAYS
         LA    R11,3(R11)          BUMP ADDR OF MONTHS
         CP    DATETIME+2(2),0(2,R10)  COMPARE DATE WITH DAYS
         BNH   NXTMONTH                  BRANCH IF LOW OR EQUAL
         SP    DATETIME+2(2),0(2,R10)  OTHERWISE SUBTRACT DAYS AND
         MVC   DATE+3(3),0(R11)        MOVE CMONTH TO HEADING
         OI    DATETIME+3,X'0F'        UNPACK DAYS
         UNPK  DATE(2),DATETIME+2(2)     INTO HEADING
         MVO   YEAR+4(4),DATETIME+4(3) SET TIME TO PACKED DECIMAL
         CP    YEAR+4(4),=P'10000'     COMPARE FOR 1 AM
         BNL   PMTEST                    BRANCH IF EQUAL OR LATER
         AP    YEAR+4(4),=P'120000'    OTHERWISE ADD 12 HOURS AND
         B     UNPKTIME                  BRANCH TO UNPACK
         SPACE
PMTEST   EQU   *
         CP    YEAR+4(4),=P'120000'    TEST FOR PM
         BL    UNPKTIME                  BRANCH TO UNPACK
         MVI   TIME+9,C'P'             CHANGE AM TO PM
         CP    YEAR+4(4),=P'130000'    COMPARE FOR 1 PM
         BNH   UNPKTIME                  BRANCH IF LESS OR EQUAL
         SP    YEAR+4(4),=P'120000'    OTHERWISE SUBTRACT 12 HOURS
UNPKTIME EQU   *
         OI    YEAR+7,X'0F'            SET UP TIME
         UNPK  DATETIME(6),YEAR+4(4)   TO UNPACK
         MVC   TIME(2),DATETIME        MOVE HOURS,
         MVC   TIME+3(2),DATETIME+2    MINUTES AND
         MVC   TIME+6(2),DATETIME+4    HUNDRETHS OF MINUTES
         XR    R5,R5                   SET LINE CT TO ZERO
         BR    R12                     RETURN
         SPACE
*---------------------------------------------------------------------*
*        ESTABLISH HEADING FOR PUNCHED OUTPUT
*---------------------------------------------------------------------*
         SPACE
PNCHHEAD EQU   *
         MVI   MODE,C'B'           SET MODE TO PUNCH
         ST    R12,REG12
         LA    R12,OUTDCB          LOAD ADDR OF OUTDCB
         MVC   DCBLRECL,=H'80'     FOR PUNCH CHANGE LRECL TO 80
         MVC   DCBBLKSI(2),=H'800' AND BLKSIZE TO 800
         NI    DCBRECFM,X'F9'      AND RECFM TO FB
         MVC   PUNCH1+19(44),JFCB  AND MOVE DSN TO HEADING
         PUT   OUTDCB,PUNCH1       AND PRINT
         MVC   HEADING2(21),ADDCARD    MOVE IN IEBUPDTE ./ ADD CARD
         L     R12,REG12           RESTORE LINKAGE REGISTER
         BR    R12                 RETURN
         SPACE
*---------------------------------------------------------------------*
*        ERROR ROUTINES
*---------------------------------------------------------------------*
         SPACE
INVLDSCN EQU   *
         PUT   MESSAGES,BADSCAN
         B     PUNT
         SPACE
INVALDCD EQU   *
         PUT   MESSAGES,FORMATER
         B     PUNT
         SPACE
PUTOPER1 EQU   *
         PUT   MESSAGES,OPTNERR1
         B     PUNT
         SPACE
PUTOPER2 EQU   *
         PUT   MESSAGES,OPTNERR2
         B     PUNT
         SPACE
PUTNOMEM EQU   *
         MVC   NOMEMBER+9(8),NAMELIST
         PUT   MESSAGES,NOMEMBER
         B     CLOSEIT
         SPACE
INVALDNM EQU   *
         PUT   MESSAGES,LONGNAME
         B     PUNT
         SPACE
IOERROR1 EQU   *
         MVC   ERROR1+51(44),JFCB
         PUT   MESSAGES,ERROR1
         B     DUMP
         SPACE
IOERROR2 EQU   *
         MVC   ERROR2+45(8),0(R9)
         PUT   MESSAGES,ERROR2
         RDJFCB (PDSDCB)
         CLC   JFCB+104(2),=H'80'
         BE    DUMP
         PUT   MESSAGES,ERROR3
DUMP     ABEND 085,DUMP
         SPACE
*---------------------------------------------------------------------*
*        END OF JOB ROUTINE
*---------------------------------------------------------------------*
         SPACE
EOJ      EQU   *
         NOP   CLOSEIT
         PUT   MESSAGES,NULLSET
         B     PUNT
         SPACE
CLOSEIT  EQU   *
         CLOSE (LIBDCB,REREAD)
         LA    R12,CARDIN
         TM    DCBOFLGS,X'10'
         BZ    STOP
         LA    R11,NEXTMEMB
         LA    R12,PDSDCB
         ST    R11,DCBEODAD
         NI    NOP6+1,X'0F'      NOP ALLOWS INIT DIR BLK READ (SCAN)
         OI    B1+1,X'F0'
         OPEN  (LIBDCB,INPUT)
         B     NEXTCARD
         SPACE
PUNT     EQU   *
         CLOSE (LIBDCB,,PDSDCB,,CARDIN)
STOP     EQU   *
         CLOSE (OUTDCB,,MESSAGES)
         XR    15,15
         L     13,4(13)
         RETURN (14,12),RC=(15)
         SPACE
*---------------------------------------------------------------------*
*        DATA CONSTANTS AND STORAGE AREAS
*---------------------------------------------------------------------*
         SPACE
DATETIME DS    D
YEAR     DC    D'0'
SCANCHAR DC    CL8' '
NAMELIST DC    CL8' '
SAVEAREA DS    18F
REG8     DS    D
JFCBADDR DC    X'87',AL3(JFCB)
REG12    DS    F
NONBLANK DC    64X'FF',X'00',191X'FF'   TRT TABLE FOR NONBLANK CHARS
BLANKLIM DC    64X'00',X'FF',191X'00'   TRT TABLE USED FOR BLANK SEARCH
DAYS     DS    F
         DC    PL2'334',PL2'335'
         DC    PL2'304',PL2'305'
         DC    PL2'273',PL2'274'
         DC    PL2'243',PL2'244'
         DC    PL2'212',PL2'213'
         DC    PL2'181',PL2'182'
         DC    PL2'151',PL2'152'
         DC    PL2'120',PL2'121'
         DC    PL2'090',PL2'091'
         DC    PL2'059',PL2'060'
         DC    PL2'031',PL2'031'
         DC    PL2'000',PL2'000'
PDSBLKSI DS    H
JFCB     DS    0F                                                    C
WORKAREA DS    CL264                                                 C
TTRC     DS    F                                                     C
MONTHS   DS    CL3
         DC    C'DEC'
         DC    C'NOV'
         DC    C'OCT'
         DC    C'SEP'
         DC    C'AUG'
         DC    C'JUL'
         DC    C'JUN'
         DC    C'MAY'
         DC    C'APR'
         DC    C'MAR'
         DC    C'FEB'
         DC    C'JAN'
PAGECNT  DC    PL2'0'
MODE     DC    X'00'
PDSAREA1 DS    0CL133
CONTROL  DC    CL1' '
PDSAREA2 DC    CL132' '
MEMBER   DC    C'MEMBER=('
SCAN     DC    C'SCAN=('
VOLSER   DC    CL9'ON VOLUME'
TS       DC    C'  O N  V O L U M E  '
UNC      DC    C'ON UNCLASSIFIED VOLUME'
PDSUTIL  DC    CL133'1 PDSPRINT UTILITY PROGRAM'
PRINTALL DC    CL133'-    PRINT ALL OPTION SELECTED'
PUNCHALL DC    CL133'-    PUNCH ALL OPTION SELECTED'
MESSAGE  DC    CL133'-'
CARD     EQU   MESSAGE+2
HEADING1 DC    CL13'1LISTING OF '                   1
DSNVOL   DC    CL78' '                              2
DATE     DC    CL12'DD MMM YY   '                   3
TIME     DC    CL14'HH.MM.SS AM   '                 4
PAGE     DC    CL16'PAGE    '                       5
HEADING2 DC    CL133'-    MEMBER NAME:'
ERROR1   DC    CL133'0 ERROR OCCURRED WHILE TRYING TO READ DIRECTORY OF*
                '
ERROR3   DC    CL133' ASFI001 - LRECL OF DATA SET/MEMBER MUST BE 80' C
ERROR2   DC    CL133'0 ERROR OCCURRED WHILE TRYING TO READ MEMBER'
NOSCAN   DC    CL133'0 NO MEMBERS FOUND BEGINNING WITH:'
NOMEMBER DC    CL133'0 MEMBER          NOT FOUND. PROCESSING WILL CONTI*
               NUE.'
OPTNERR2 DC    CL133'0 INVALID OPERAND FIELD. PROCESSING HALTED.'
OPTNERR1 DC    CL133'0 OPERATION FIELD DOES NOT MATCH PREVIOUS OPERATIO*
               NS OR IS INVALID. PROCESSING HALTED.'
FORMATER DC    CL133'0 FORMAT ERROR ON CONTROL CARD. PROCESSING HALTED.*
               '
LONGNAME DC    CL133'0 MEMBER NAME CONTAINS TOO MANY CHARACTERS. PROCES*
               SING HALTED.'
BADSCAN  DC    CL133'0 INVALID SCAN FIELD . PROCESSING HALTED.'
BLANKS   EQU   PDSPRINT+((BADSCAN+60-PDSPRINT)/8)*8 DBLWD BLNKS(WHY NOT
BADPARM  DC    CL133'0 UNRECOGNIZED PARM FIELD:''XXXXX'' - IF CODED, IT*
                MUST BE ''A'' OR ''PRINT'', ''B'' OR ''PUNCH''.'
ADDCARD  DC    CL21'./ ADD LIST=ALL,NAME='
NULLSET  DC    CL133'0 INPUT DATA SET IS EMPTY. PROCESSING HALTED.'
PUNCH1   DC    CL80'PUNCHED MEMBERS OF DSN'
         SPACE
*---------------------------------------------------------------------*
*        EXECUTE AND TRANSLATE AND TEST INSTRUCTIONS
*---------------------------------------------------------------------*
         SPACE
TRT1     TRT   0(70,R8),NONBLANK
         BZ    INVALDCD
         B     OPFIELD
         SPACE
TRT2     TRT   0(0,R8),NONBLANK
TRT3     TRT   0(0,R8),BLANKLIM
MOVENAME MVC   NAMELIST(0),0(R8)
MOVESCAN MVC   SCANCHAR(0),0(R8)
         SPACE
*---------------------------------------------------------------------*
*        DATA CONTROL BLOCKS
*---------------------------------------------------------------------*
         SPACE
CARDIN   DCB   DDNAME=SYSIN,MACRF=GM,EODAD=PUNT,RECFM=FB,LRECL=80,     X
               DSORG=PS
MESSAGES DCB   DDNAME=SYSPRINT,MACRF=PM,RECFM=FBA,LRECL=133,           *
               BLKSIZE=1330,DSORG=PS
LIBDCB   DCB   DDNAME=SYSUT1,MACRF=R,EODAD=EOJ,RECFM=F,KEYLEN=8,       *
               BLKSIZE=256,DSORG=PS,EXLST=JFCBADDR,SYNAD=IOERROR1
PDSDCB   DCB   DDNAME=SYSUT1,MACRF=R,EODAD=NEXTMEMB,DSORG=PO,          *
               SYNAD=IOERROR2,EXLST=JFCBADDR                         C
OUTDCB   DCB   DDNAME=SYSUT2,MACRF=PM,RECFM=FBA,LRECL=133,DSORG=PS,    *
               BLKSIZE=1330
         LTORG
         SPACE
         DCBD  DSORG=PO,DEVD=DA
         END   PDSPRINT
//LKED.SYSLMOD DD DSN=SYS2.LINKLIB,DISP=SHR                             00080000
//LKED.SYSIN DD *                                                       00090000
 NAME PDSPRINT(R)                                                       00100000
//                                                                      00110000
