//LISTPDS  JOB (TSO),
//             'Install LISTPDS',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//* ********************************************************            00020000
//* *  INSTALL THE 'LISTPDS'  PROGRAM                      *            00030000
//* ********************************************************            00040000
//LISTPDS  EXEC ASMFCL                                                  00050000
//*        PARM.ASM='OBJECT,NODECK,LIST',                               00060000
//*        PARM.LKED='LIST,MAP'                                         00070000
//SYSIN    DD *                                                         00080000
LPDS TITLE 'LISTPDS  --  LIST PARTITIONED DATA SET UTILITY PROGRAM'
*---------------------------------------------------------------------*
*
* TITLE - LIST PARTITIONED DATA SET UTILITY PROGRAM
*
* NAME - LISTPDS,  ENTRY POINT - LISTPDS
*
* STATUS - VERSION 7.3,  UPDATED 27MAR78
*          VERSION 7.3A  UPDATED 04DEC81
*                        AIR FORCE DATA SERVICES CENTER, THE PENTAGON.
*                        BILL GODFREY, PLANNING RESEARCH CORPORATION.
*          VERSION 8.0   UPDATED 01JAN94
*                        FINANCIAL MANAGEMENT SERVICE, US TREASURY
*                        JIM MARSHALL, CAPT, USAF-RET
*
* DEVELOPED BY . . .
*       GENE CZARCINSKI
*       NASA/GODDARD SPACE FLIGHT CENTER
*       GREENBELT, MARYLAND
*
* FUNCTION/OPERATION - "LISTPDS" IS AN OS/360 DATA SET UTILITY
*       PROGRAM FOR LISTING AND/OR PUNCHING SOURCE/OBJECT LIBRARIES
*       (PARTITIONED DATA SETS).  ALL MEMBERS PROCESSED BY LISTPDS
*       ARE ALWAYS OUTPUTTED IN COLLATING SEQUENCE (EXCEPT WHEN
*       SELECTED MEMBERS ARE PROCESSED).  LISTPDS GENERATES
*       TWO FORMATTED PRINTOUTS -
*          1. (ON SYSPRINT) A FORMATTED LISTING OF THE PDS'S
*             DIRECTORY TOGETHER WITH THE PAGE NUMBERS OF THE
*             OUTPUT LISTING (FOR EACH MEMBER).
*          2. (ON SYSLIST) A FORMATTED PRINTOUT OF THE CONTENTS
*             OF EACH MEMBER PROCESSED.
*
*---------------------------------------------------------------------*
*
* ATTRIBUTES - ENABLED, SERIALLY REUSABLE, BLOCK LOADED,
*       SINGLE LOAD MODULE, NO OVERLAY.
*
* ACCESS METHODS - QSAM LOCATE MODE (RECFM=FB) USED FOR
*       SYSPRINT, SYSLIST, SYSPUNCH;  BSAM/BPAM USED FOR
*       PDS I/O (SYSLIB); BSAM IS USED FOR SYSIN;
*       AND EXCP IS USED FOR PDS-DIRECTORY READING.
*
*
* NOTES -
*       1. VERSION 6 OF "LISTPDS" IS A MAJOR REDESIGN OF THE
*          PROGRAM AND REPLACES ALL PREVIOUS VERSIONS.
*       2. ASIDE FROM THE EDIT (ED) DECIMAL INSTRUCTION, "LISTPDS"
*          IS CODED ENTIRELY WITH STANDARD INSTRUCTION SET (360)
*          INSTRUCTIONS.
*       3. "LISTPDS" DOES ITS OWN DIRECTORY PROCESSING AND ALWAYS
*          READS THE ENTIRE DIRECTORY (USING BSAM).
*       4. DEFAULT SWITCH AND DDNAMES CAN BE CHANGED BY MODIFYING
*          THE ASSEMBLY VARIABLES.
*       5. THE STANDARD TRANSLATE TABLES ARE SETUP FOR 'QN'
*          PRINT CHAIN OUTPUT.
*       6. ALL PRINTED OUTPUT USES ASA CONTROL CHARACTERS.
*       7. TO BE PROPERLY PROCESSED BY LISTPDS, ALL PDS
*          DIRECTORIES *MUST* BE IN STANDARD FORMAT: THE LAST
*          ENTRY IN EACH DIRECTORY IS HEX F'S.
*       8. CODE HAS BEEN ADDED TO HANDLE PROCESSING OF CONCATON-
*          ATED SYSLIB DD STATEMENTS.
*       9. LISTPDS OPERATION IS DEPENDENT ON THE ASSUMED LAYOUT
*          OF THE SYSLIB JFCB'S, DSCB'S AND THE "CAMLST" GENERATED
*          CONTROL BLOCK FOR READING THE DSCB.
*      10. LISTPDS OPERATION IS DEPENDENT ON THE ASSUMED OPERATION
*          OF THE BPAM READ & FIND (C) ROUTINES FOR DIRECTORY AND
*          MEMBER READING.
*      11. DEFAULT BLKSIZES HAVE BEEN CHANGED FROM UNBLOCKED
*          TO BLOCKED --
*                 SYSPRINT - 3509
*                 SYSLIST  - 7260
*                 SYSPUNCH - 3200
*                 SYSIN    - 3200
*      12. THE DEFAULT BUFNO IS NOW SET TO 2.
*      13. THE DEFAULT MAX LINES/PAGE IS NOW SET TO 60.
*
* VERSION 7.0 --
*      14. DEFAULT MAX LINES/PAGE NOW SET TO 84.
*      15. STAE PROCESSING HAS BEEN REMOVED.
*      16. ALL VCONS HAVE BEEN CHANGED TO ADCONS.
*      17. MAX OUTPUT LINE LENGTH CHANGED TO 116 CHARACTERS.
*      18. PUNCHING ONLY OUTPUTS UP TO THE FIRST 80 BYTES OF
*          EACH LOGICAL RECORD.
*      19. THE XLATE (TRANSLATE) FUNCTION HAS BEEN DELETED.
*      20. ABEND60A FIXED (BUG IN 'CLEARBUF')
*      21. EJECT/NOEJECT FUNCTION IMPLEMENTED.
*
* VERSION 7.1 --
*      22. REWORK CODE TO MAKE IT ONE CSECT
*      23. FIX 7.0 BUG IN 'MONTHS'
*      24. REFORMAT SOURCE CODE TO MAKE MORE READABLE.
*      25. CHANGE PARM-ANAL TO SKIP OVER BAD KEYWORDS
*      26. PAGE EJECT SYSLIST BETWEEN LIBRARIES
*      27. TEST FOR 'NEAR BOTTOM' AND EJECT SYSLIST IF SO
*      28. PUT TITLE AT TOP AND BOTTOM OF SYSLIST IF IN EJECT MODE.
*      29. CREATE SYSPRINT HEADER PAGE AND TRAILOR PAGE.
*      30. REWORK LIB-FILE INIT CODE TO USE THE 'LCB' AREAS AND
*          COUNT THE NUMBER OF DIR BLOCKS PER TRACK.
*      31. REWORK DIR READ TO USE EXCP I/O.
*      32. DEFAULT MAXLINES CHANGED TO 80.
*      33. ADD MAXLIST, SELECT, AND EXCLUDE OPTIONS.
*      34. CHANGE PRINT, LIST AND PUNCH TO USE QSAM MOVE I/O.
*      35. REWORK CORE MANAGEMENT TO ISSUE ONE LARGE GETMAIN
*          AND DO SUBALLOCATION FROM THAT AREA.
* VERSION 7.2 --
*      36. MAKE SELECT/EXCLUDE WORK FOR SPECIFIED MEMBERS
*      37. REWORK LOUT SO THAT ADCON IS USED FOR LIST DCB ADDR
*      38. REWORK LOUT SO THAT BOTTOM OF PAGE PROCESSING FOR
*          NOEJECT MODE WORKS PROPERLY
*      39. CHECK FOR RECFM=V/VB AND USE SECONDARY DCB IF SO
*          TO PERFORM PROPER I/O (NO I/O ERRORS).
*      40. CREATE S/R TO FORMAT & PRINT SYSPRINT DATA FOR
*          FOR MEMBER SO IT CAN BE USED AFTER A MEMBER IS
*          PROCESSED (SAVE INFO IN THE 'DIR' AREA).
*      41. REORGANIZE CODE TO PROVIDE MORE BASE REGISTER
*          ADDRESSABILITY BY MOVING SOME OF THE INITIALIZATION
*          CODE INTO SEPARATELY ADDRESSABLE SUBROUTINES.
*      42. ADD THE CAPABILITY TO LIST/PUNCH SEQUENTIAL DATASETS
*          WHICH ARE POINTED TO BY THE SYSLIB CONCATENATION.
*      43. CODE ADDED TO RE-INIT DCB IF RECFM CHANGES
*          SO THAT THE DATASET WILL BE PROCESSED CORRECTLY
*          WITH NO 'I/O ERRORS'.
*      44. REWORK CODE SO THAT A SPECIAL END MSG WILL BE
*          ISSUED IF PROCESSING A SEQUENTIAL DATASET.
*      45. COUNTERS ADDED FOR PDS AND SDS PROCESSING.
*      46. MODIFY DATASET I/O ERROR HANDLING TO LIST
*          THE CONCATENATION SEQUENCE NUMBER SO THAT
*          THE DATASET CAN BE IDENTIFIED AND THEN
*          GO LIST THE PROCESSED DIRECTORY ENTRIES IF
*          A PDS; PRODUCE AN EXTRA I/O ERROR MSG AT END
*          OF DIRECTORY LISTING.
*      47. CHANGE THE CODE TO ALLOCATE THE DATASET READ BUFFERS
*          BASED ON THE SIZE OF EACH DATASET BEING PROCESSED.
*
* VERSION 7.3 --
*      48. FIX RITSINFO/CRJEINFO SO DIRECTORY ENTRY IS LISTED
*          CORRECTLY FOR RITS/CRBE/CRJE LIBRARIES.
*      49. FIX BUG WHICH CAUSES ABEND0C0 WHEN "EXCLUDE" IS
*          SPECIFIED FOR SELECTED MEMBERS.
*
* VERSION 7.3A -- UPDATES AT AIR FORCE DATA SERVICES CENTER, PENTAGON
*          04 DEC 81, BILL GODFREY, PLANNING RESEARCH CORPORATION.
*      50. FOR DECK AND UPDTE, PUT SSI= KEYWORD AFTER THE MEMBER NAME
*          ON THE ./ ADD STATEMENT, INSTEAD OF BEFORE.
*      51. IF UPDTE IS SPECIFIED AND A MEMBER CONTAINS IEBUPDTE
*          STATEMENTS, THE './' STATEMENTS WITHIN THE MEMBER WILL
*          BE PUNCHED WITH THE './' CHANGED TO '><'. SEE NOTE 54 TOO.
*      52. GET TIOT ADDRESS DIRECTLY INSTEAD OF GOING THRU EXTRACT SVC.
*      53. ADD NEW PARM OPTION 'NOSEL' TO IGNORE SYSIN,
*          SO WE CAN KEEP SYSIN ALLOCATED TO THE TERMINAL UNDER TSO.
*      54. SPF (AN IBM PROGRAM PRODUCT) STATISTICS IN A PDS DIRECTORY
*          WILL BE FORMATTED ON SYSPRINT AND IN THE COMMENTS AREA
*          OF ./ ADD STATEMENTS.
*          NOTE: WE HAVE A PROGRAM THAT WILL RE-LOAD THE IEBUPDTE DECK
*          TO A PDS AND RESTORE THE SPF STATS FROM THE ./ ADD CARD.
*          (AND RESTORE '><' TO './' --- SEE NOTE 51).
*      55. IF 'NOSPF' IS SPECIFIED, OR IF NO MEMBERS IN A PDS CONTAIN
*          SPF STATISTICS, THEN THE OLD HEX FORMATTING WILL BE USED.
*      56. DEFAULT MAXLINES CHANGED TO 60.
*      57. JUST PRINT HH.MM OF TIME IN HEADING, NOT HH.MM.SS
*      58. INSTEAD OF VOL=VVVVVV, DSN=DDDDDDDDDDDDD    IN HEADINGS,
*               PRINT - DDDDDDDDD - VOL=VVVVVV
*      59. SUPPRESS ZEROS IN PAGE INDEX OF LISTDIR, SO PAGE 0 WILL
*          BE PAGE BLANK.
*      60. SUPPRESS ZEROS IN LRECL, BLKSIZE.  LEFT JUSTIFY.
*      61. DEFAULT EJECT.
*      62. REDUCE LINEMAX BY 1 INTERNALLY, BECAUSE WE KEEP GETTING
*          ONE MORE LINE PER PAGE THAN THE SPECIFIED LINECNT.     .LCT.
*      63. HEADINGS CHANGED. MEMBER NAME ON LEFT.                 .LCT.
*
* VERSION 8.0 --
*      64. ADDED INTO OPTIONS LIST SPF/NOSPF.
*      65. ADDED DSECTS WHERE EVER POSSIBLE IN PREPARATION FOR MVS/ESA.
*      66. MADE THE CODE MORE READABLE FOR FUTURE GENERATIONS.
*      67. BACKLEVEL TO COMPILE UNDER IFOX00 UNDER MVS 3.8.       *JLM*
*---------------------------------------------------------------------*
         EJECT
*---------------------------------------------------------------------*
*        LOCAL MACRO DEFINITIONS
*---------------------------------------------------------------------*
         MACRO
&N       CRJE      &A,&B,&C,&D,&E
&N       TM        &A.(R2),&B
         BNO       X&SYSNDX
         MVC       0(&D,R1),=C&C
         LA        R1,&D.(R1)
         B         &E
X&SYSNDX EQU       *
         MEND
*
         MACRO
&A       PACL  &B,&C,&D,&E,&F,&G,&H,&J
&A       CLC   =C'&B',0(R2)
         BNE   Z&SYSNDX
         LA    R2,&C.(,R2)
         &D    &E,&F
         AIF   (T'&G EQ 'O').A
         &G    &H,&J
.A       B     PAEND
Z&SYSNDX EQU   *
         MEND
*
         MACRO
&A       P1    &B,&C,&D,&E,&BR=BZ
&A       TM    &B,&C
         &BR   X&SYSNDX
         MVC   0(&E.,R2),=C'&D'
         LA    R2,&E.(,R2)
         BAL   R10,PRMLSTXX
X&SYSNDX EQU   *
         MEND
*
         MACRO
&A       P2    &B,&C,&D,&E
&A       TM    &B,&C
         BO    X&SYSNDX
         MVC   0(2,R2),=C'NO'
X&SYSNDX MVC   2(&E.,R2),=C'&D'
         LA    R2,&E.+2(,R2)
         BAL   R10,PRMLSTXX
         MEND
*
         MACRO
&A       CC    &B,&C,&D,&E
&A       LA    R1,&B       LINECNT
         CLI   &C.,C'&D'   IS THE THE CHAR?
         BE    &E          YES.
         MEND
         EJECT
*---------------------------------------------------------------------*
*        ASSEMBLY VARIABLES
*---------------------------------------------------------------------*
         SPACE
         LCLC  &RELEASE,&ID,&VERSION
         LCLC  &DDIN,&DDPRINT,&DDPUNCH,&DDLIB,&DDLIST
         LCLB  &A(8),&B(8)
         LCLB  &E(8)                                              *JLM*
&RELEASE SETC  '01JAN94'           RELEASE IDENT - MAX 7 BYTES
&VERSION SETC  '8.0'               VERSION IDENTIFICATION
&ID      SETC  'GSFC'              'LOCAL' IDENT - 4 BYTES MAX
&DDIN    SETC  'SYSIN'             DDNAME: CONTROL INPUT
&DDPRINT SETC  'SYSPRINT'          DDNAME: MAIN-PRINT OUTPUT
&DDLIST  SETC  'SYSLIST'           DDNAME: LISTING OUTPUT
&DDPUNCH SETC  'SYSPUNCH'          DDNAME: FOR PUNCHED OUTPUT
&DDLIB   SETC  'SYSLIB'            DDNAME: LIBRARY INPUT
&A(1)    SETB  1                   LIST
&A(2)    SETB  0                   NODECK
&A(3)    SETB  0                   NOT 'LIST DIR ONLY'
&A(4)    SETB  0                   NOUPDTE
&A(5)    SETB  0
&A(6)    SETB  1                   EJECT           (WAS NOEJECT)  .PRC.
&A(7)    SETB  0                   SSI
&A(8)    SETB  1                   TRUNC
&B(1)    SETB  0                   NODEBUG
&B(2)    SETB  0                   NOHEXOUT
&B(3)    SETB  0
&B(4)    SETB  0                   NONUM
&B(5)    SETB  0                   EROPT=TERM
&E(1)    SETB  1                   SEL                            .SEL.
&E(2)    SETB  1                   SPF                            .SPF.
         EJECT
R0       EQU   0                   OS PARM REG; WORK REG
R1       EQU   1                   OS PARM REG; WORK REG
R2       EQU   2                   LOCAL WORK REG
R3       EQU   3                   LOCAL WORK REG
R4       EQU   4
R5       EQU   5                   LRECL CNTR FOR MEMBER
R6       EQU   6                   BLOCK LENGTH
R7       EQU   7                   BLOCK POINTER
R8       EQU   8                   IHADCB BASE REG
R9       EQU   9                   MAIN BASE REG - 3
R10      EQU   10                  LOCAL LINK REG
R11      EQU   11                  PROGRAM BASE REG #2
R12      EQU   12                  MAIN BASE REG - 1
R13      EQU   13                  POINTER TO OS SAVE AREA
R14      EQU   14                  OS LINK REG; WORK REG
R15      EQU   15                  OS BRANCH REG; WORK REG
MAXLINE  EQU   60                  'DEFAULT' LINES/PAGE (WAS 80)  .PRC.
SWA0     EQU   B'10000000'         NOLIST/LIST
SWA1     EQU   B'01000000'         NODECK/DECK
SWA2     EQU   B'00100000'         LIST DIRECTORY ONLY
SWA3     EQU   B'00010000'         NOUPDTE/UPDTE
SWA4     EQU   B'00001000'         MAXLIST SPECIFIED
SWA5     EQU   B'00000100'         NOEJECT/EJECT
SWA6     EQU   B'00000010'         NOSSI/SSI
SWA7     EQU   B'00000001'         NOTRUNC/TRUNC
SWB0     EQU   B'10000000'         NODEBUG/DEBUG
SWB1     EQU   B'01000000'         NOHEXOUT/HEXOUT
SWB2     EQU   B'00100000'         0: LIST=LIST,  1: LIST=PRINT
SWB3     EQU   B'00010000'         NONUM/NUM
SWB4     EQU   B'00001000'         EROPT=TERM/ACC
SWC0     EQU   B'10000000'         PARM ANALYSIS ERROR
SWC1     EQU   B'01000000'         FLAG FOR NEW PAGE BEFORE PRINT
SWC2     EQU   B'00100000'         1: DSORG=PS BEING PROCESSED.
SWC3     EQU   B'00010000'         TERMINATE MODE SWITCH
SWC7     EQU   B'00000001'         DCB EXIT TAKEN
SWD0     EQU   B'10000000'         SELECTED NAMES SPECIFIED
SWD1     EQU   B'01000000'         MEMBER IS AN ALIAS
SWD2     EQU   B'00100000'         0=SELECT, 1=EXCLUDE
SWD3     EQU   B'00010000'         SYSPRINT FIRST TIME THRU
SWD4     EQU   B'00001000'         "00"=NOTHING, "10"=RITS,
SWD5     EQU   B'00000100'         "01"=CRBE, "11"=CRJE.
SWD6     EQU   B'00000010'         SYSLIST FIRST TIME THRU SWITCH
SWD7     EQU   B'00000001'         1=RITS/CRBE/CRJE LIB BEING PROC.
SWE0     EQU   B'10000000'         SEL                            .SEL.
SWE1     EQU   B'01000000'         SPF                            .SPF.
SWE2     EQU   B'00100000'         SPF STATS FOUND IN CURRENT PDS .SPF.
SWE3     EQU   B'00010000'         SPF STATS IN ANY PDS           .SPF.
OFLGS    EQU   B'00010000'         DCB OPEN ERROR FLAG
ALIAS    EQU   B'10000000'         ALIAS BIT IN DIRECTORY ENTRY
CVTPTR   EQU   16   ... ADDR OF THE OS CVT
CVTPCNVT EQU   X'1C' .. OFFSET IN CVT TO ADDR OF TTR/CCHHR CNVT
JFCBDSNM EQU   0                   DSNAME OFFSET IN JFCB
JFCBVOLS EQU   118                 VOLSER OFFSET IN JFCB
JFCDSORG EQU   98                  DSORG  OFFSET IN JFCB
JFCRECFM EQU   100                 RECFM  OFFSET IN JFCB
JFCBLKSI EQU   102                 BLKSIZ OFFSET IN JFCB
JFCLRECL EQU   104                 LRECL  OFFSET IN JFCB
DS1DSORG EQU   82-44               DSORG  OFFSET IN DSCB
DS1RECFM EQU   84-44               RECFM  OFFSET IN DSCB
DS1BLKSI EQU   86-44               BLKSIZ OFFSET IN DSCB
DS1LRECL EQU   88-44               LRECL  OFFSET IN DSCB
DS4DEVDB EQU   75-44               DIR/TR OFFSET IN F=4 DSCB
         EJECT
*---------------------------------------------------------------------*
*        MAIN PROGRAM BEGIN
*---------------------------------------------------------------------*
* LISTPDS  AMODE 24                                               *JLM*
* LISTPDS  RMODE 24                                               *JLM*
LISTPDS  CSECT
         SAVE  (14,12),,LISTPDS-&VERSION
         LR    R12,R15             INIT MAIN BASE REGS
         LA    R11,2048
         AR    R11,R11
         LR    R9,R11
         AR    R9,R9
         AR    R11,R12
         AR    R9,R12
         USING LISTPDS,R12,R11,R9  AND PGM ADDRESSABILITY.
         USING IHADCB,R8           SET DCB ADDRESSABILITY
         LR    R4,R1               SAVE PARM LIST POINTER.
         LA    R15,SAVEAREA        INIT SAVE AREAS
         ST    R13,4(R15)
         ST    R15,8(R13)
         LR    R13,R15
         SPACE
*---------------------------------------------------------------------*
*        PROGRAM INITIALIZATION
*---------------------------------------------------------------------*
         SPACE
PGMINIT  EQU   *
         XC    SWITCHES,SWITCHES   CLEAR SIWTCHES, ETC.
         LA    R8,SYSLIB
         MVI   DCBRECFM,0          MAKE SURE DCB IS INITIALIZED.
         XC    DCBLRECL,DCBLRECL
         XC    DCBBLKSI,DCBBLKSI
         MVI   EXLST2,X'05'
         XC    COR2,COR2
         XC    COR7,COR7
         XC    COR8,COR8
         MVC   ALISTDCB,=A(SYSLIST)
         MVI   HEAD1,C' '
         MVC   HEAD1DAT(HEAD1NAM-HEAD1),HEAD1
         MVC   HEAD1DSN(L'HEAD1VER),HEAD1VER
         MVC   HEAD1(L'HEAD1R),HEAD1R  INIT HEADER LINE
         MVC   SWA,SWAX
         MVC   SWB,SWBX
         MVC   SWE,SWEX
         XC    RECORDS,RECORDS     CLEAR COUNTER
         XC    TTRK,TTRK           FOR FIND
         XC    RETCODE,RETCODE
         XC    PAGENUM1,PAGENUM1
         XC    PAGENUM2,PAGENUM2
         XC    LINECNT1,LINECNT1
         XC    LINECNT2,LINECNT2
         XC    BUFFER1,BUFFER1     CLEAR BUFFERS
         XC    BUFFER2,BUFFER2
         LA    R15,MAXLINE         SET DEFAULT LINE COUNT
         BCTR  R15,0                                              .LCT.
         STH   R15,LINEMAX
         LA    R15,4000
         STH   R15,LINECNT1
         XC    TOTALREC,TOTALREC
         XC    NAMETBL1,NAMETBL1
         XC    NAMETBL2,NAMETBL2
         XC    MAXLIST,MAXLIST
         MVC   DDPRINT(RESETDDL),RESETDD
         TM    0(R4),X'80'         ONLY EXEC PARMS SPECIFIED?
         BO    EXTRACT             YES.
         L     R2,4(R4)            NO, INIT THE DDNAMES.
         LH    R3,0(R2)            GET NO. OF BYTES IN LIST
         LTR   R3,R3               IS IT ZERO?
         BNP   XPA2                YES, SKIP
         CH    R3,=H'40'
         BNH   *+8
         LA    R3,40
         LA    R2,2(R2)            BEGINNING OF DD LIST
         LA    R3,2(R3,R2)         END OF DD LIST
         LA    R1,DDPRINT          LISTPDS'S DD LIST
XPA1     EQU   *
         CR    R2,R3               END OF LIST?
         BNL   XPA2                YES, GOTO NEXT ONE
         CLI   0(R2),0             DUMMY ENTRY?
         BE    *+10                YES, SKIP MOVE
         MVC   0(8,R1),0(R2)
         LA    R1,8(R1)
         LA    R2,8(R2)
         B     XPA1
         SPACE
XPA2     EQU   *
         TM    4(R4),X'80'         END OF PARM LIST?
         BO    EXTRACT             YES
         L     R2,8(R4)
         L     R2,0(R2)
         STH   R2,PAGENUM1         INITIAL PAGE NO - SYSPRINT
         TM    8(R4),X'80'
         BO    EXTRACT
         L     R2,12(R4)
         L     R2,0(R2)
         STH   R2,PAGENUM2         INITIAL PAGE NO - SYSLIST
*XTRACT  EXTRACT TIOT,'S',FIELDS=(TIOT)                          *.PRC.
EXTRACT  L     R1,540              PSATOLD, CURRENT TCB           .PRC.
         L     R1,12(,R1)          GET TIOT ADDRESS FROM TCBTIO   .PRC.
         ST    R1,TIOT             SAVE TIOT ADDRESS              .PRC.
         SPACE
*---------------------------------------------------------------------*
*        INIT DATE/TIME FOR PRINTOUTS
*---------------------------------------------------------------------*
         SPACE
         TIME  DEC                 GET DATE & TIME FOR HEADING
         ST    R0,WORK1
         XC    WORK2,WORK2         COMPUTE AND FORMAT DATE
         ST    R1,WORK2+4
         MVC   WORK1+5(1),WORK2+5  SAVE YEAR
         CVB   R3,WORK2            CONVERT DATE TO BINARY
         XR    R2,R2
         D     R2,=F'1000'         TO SEP YEAR AND DAY
         ST    R3,WORK2
         LA    R3,MONTHS1          FOR STD YEAR
         TM    WORK2+3,X'03'       LEAP YEAR?
         BNZ   *+8                 NO
         LA    R3,MONTHS2          FOR LEAP YEAR
         XR    R1,R1
PGMINITX EQU   *
         SH    R2,0(R3)
         BNP   PGMINITY
         LA    R1,3(R1)
         LA    R3,2(R3)
         B     PGMINITX
         SPACE
PGMINITY EQU   *
         AH    R2,0(R3)
         MH    R2,=H'10'
         CVD   R2,WORK2            FOR DAY OF MONTH
         LA    R1,MONTHS3(R1)      FOR MONTH IN CHARS
         MVC   HEAD1DAT+3(3),0(R1)
         MVC   WORK1+4(1),WORK2+6  DAY OF MONTH
         ED    HEAD1DAT,WORK1+4
         CLI   HEAD1DAT+1,C' '
         BNE   *+8
         MVI   HEAD1DAT+1,C'0'
         ED    HEAD1TIM,WORK1
         CLI   HEAD1TIM+1,C' '
         BNE   *+8
         MVI   HEAD1TIM+1,C'0'
         MVC   HEAD1TIM+6(3),=C'   '                              .PRC.
         MVC   HEAD2DAT,HEAD1DAT
         MVC   HEAD2TIM,HEAD1TIM
         SPACE
*---------------------------------------------------------------------*
*        INITIALIZE THE SYSPRINT FILE
*---------------------------------------------------------------------*
         SPACE
         LA    R8,SYSPRINT         INIT THE SYSPRINT FILE
         MVC   DCBDDNAM,DDPRINT
         OPEN  (SYSPRINT,OUTPUT)
         TM    DCBOFLGS,OFLGS      OPEN OK?
         BO    INITPR              YES.
         L     R2,TIOT             SYSPRINT OPEN ERROR
         MVC   WTP+17(8),0(R2)     MOVE JOBNAME TO MSG.
         MVC   WTP+40(L'DDPRINT),DDPRINT
WTP      EQU   *
         WTO   'LPDS00I  JOBNAMEX OPEN ERROR ON SYSPRINT',         +++++
               ROUTCDE=(11),DESC=7
         TM    SWB,SWB0            DEBUG?
         BZ    ABORT               NO
         ABEND 20,DUMP             YES, ABEND TO GET DUMP.
ABORT    EQU   *
         L     R13,4(R13)          ELSE ... ABORT
         RETURN (14,12),T,RC=20
RESETDD  DC    CL8'&DDPRINT',CL8'&DDLIST',CL8'&DDPUNCH'
         DC    CL8'&DDLIB',CL8'&DDIN'
RESETDDL EQU   *-RESETDD
         SPACE
INITPR   DS    0H
         MVI   LINE1,C'-'
         BAL   R10,PRNT
         SPACE
*---------------------------------------------------------------------*
*        GO PERFORM THE PARM ANALYSIS
*---------------------------------------------------------------------*
         SPACE
         L     R6,=A(PA)
         BR    R6
         SPACE
*---------------------------------------------------------------------*
*        COMPLETE THE PARM ANALYSIS
*---------------------------------------------------------------------*
         SPACE
PGMINITA EQU   *
         TM    SWD,SWD4+SWD5       RITS/CRBE/CRJE?
         BZ    *+12                NO.
         OI    SWD,SWD7            YES.
         NI    SWA,255-SWA6        NO SSI IF RITS/CRBE
         SPACE
*---------------------------------------------------------------------*
*        LIST & PUNCH FILE INITIALIZATION
*---------------------------------------------------------------------*
         SPACE
         TM    SWA,SWA0            LIST?
         BZ    PGMINITC            NO.
         LA    R8,SYSLIST
         MVC   DCBDDNAM,DDLIST
         OPEN  (SYSLIST,OUTPUT)
         TM    DCBOFLGS,OFLGS      OPEN OK?
         BO    PGMINITC            YES.
         NI    SWA,255-SWA0        NO, SET NOLIST.
         OI    SWC,SWC1            ISSUE WARNING MSG
         MVC   LINE1(LPDS09IL),LPDS09I
         MVC   LINE1+L'LPDS09I(L'DDLIST),DDLIST
         BAL   R10,PRNT
         LA    R1,4
         BAL   R14,SAVERC
PGMINITC EQU   *
         LA    R8,SYSPUNCH
         MVC   DCBDDNAM,DDPUNCH
         TM    SWA,SWA1            NODECK?
         BZ    PGMINITD            YES.
         OPEN  (SYSPUNCH,OUTPUT)
         TM    DCBOFLGS,OFLGS      OPEN OK?
         BO    PGMINITD            YES.
         NI    SWA,255-SWA1        TURN OFF DECK OPTION
         OI    SWC,SWC1            ISSUE WARNING MSG
         MVC   LINE1(LPDS09IL),LPDS09I
         MVC   LINE1+L'LPDS09I(L'DDPUNCH),DDPUNCH
         BAL   R10,PRNT
         LA    R1,4
         BAL   R14,SAVERC
         SPACE
*---------------------------------------------------------------------*
*        ALLOCATE THE MAIN WORKAREA
*---------------------------------------------------------------------*
         SPACE
PGMINITD EQU   *
         GETMAIN VU,LA=COR1,A=COR2
         L     R1,COR2
         ST    R1,COR3
         L     R15,COR2+4
         LH    R0,=Y(8*1024)
         SR    R15,R0
         ST    R15,COR2+4
         AR    R1,R15
         AL    R15,COR2
         SH    R15,=H'8'           MAKE IT LOW TO BE SAFE
         ST    R15,COR5
         FREEMAIN R,LV=(0),A=(1)
         LM    R14,R15,COR2        CLEAR THE WORKAREA
PGMINITG EQU   *
         SH    R15,=H'256'
         BNP   PGMINITH
         XC    0(256,R14),0(R14)
         LA    R14,256(,R14)
         B     PGMINITG
         SPACE
PGMINITH EQU   *
         BAL   R14,RESETHI
         BAL   R14,RESETLO
         L     R1,COR2+4
         SRL   R1,10
         CVD   R1,WORK1
         OI    WORK1+7,X'F'
         UNPK  MSG7A,WORK1
         MVC   LINE1(MSG7L1),MSG7
         BAL   R10,PRNT
         SPACE
*---------------------------------------------------------------------*
*        INITIALIZE SYSLIB AND THE LCB'S
*---------------------------------------------------------------------*
         SPACE
FILEINIT EQU   *
         LA    R8,SYSLIB
         OPEN  (SYSLIB,INPUT)
         TM    DCBOFLGS,OFLGS      OPEN OK?
         BO    FI07                YES.
         MVC   LINE1(L'LPDS04I),LPDS04I
         MVC   LINE1+L'LPDS04I(8),DDLIB
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
*---------------------------------------------------------------------*
*        LCB INIT FOR SYSLIB CONCATONATION
*---------------------------------------------------------------------*
         SPACE
FI07     EQU   *
         MVC   WORK1(L'DCBTIOT),DCBTIOT  SAVE ENTRY
         LH    R2,DCBTIOT
         L     R3,TIOT
         LA    R3,0(R3,R2)         PNTR TO SYSLIB ENTRY
         LA    R0,LCBLEN           ALLOC INITIAL LCB
         BAL   R14,GETBASE
         LR    R4,R1
         ST    R1,ALCB
         USING LCB,R4
         LA    R5,16               LIMIT MAX LIBS PROCESSED
         LA    R0,176              SIZE OF A JFCB
         BAL   R14,GETHI
         ST    R1,JFCBADRS
         MVI   JFCBADRS,X'87'
         B     FI07B
         SPACE
FI07A    EQU   *
         XR    R1,R1
         IC    R1,0(R3)
         LA    R2,0(R2,R1)         POINT TO NEXT ENTRY
         LA    R3,0(R3,R1)
         CLI   0(R3),0             END OF TIOT?
         BE    FI07Z               YES
         CLC   =CL8' ',4(R3)       CONCATONATION?
         BNE   FI07Z               NO, END.
         STH   R2,DCBTIOT
FI07B    RDJFCB    SYSLIB
         L     R1,JFCBADRS
         MVC   DSNAME,JFCBDSNM(R1)
         MVC   LCBDSNAM,JFCBDSNM(R1)
         MVC   VOLSER,JFCBVOLS(R1)
         MVC   LCBVOLNO,JFCBVOLS(R1)
         MVC   LCBJFCDS,JFCDSORG(R1)
         MVC   LCBJFCRF,JFCRECFM(R1)
         MVC   LCBJFCBL,JFCBLKSI(R1)
         MVC   LCBJFCLR,JFCLRECL(R1)
         OBTAIN DSCB
         MVC   LCBDS1DS,WORKAREA+DS1DSORG
         MVC   LCBDS1RF,WORKAREA+DS1RECFM
         MVC   LCBDS1BL,WORKAREA+DS1BLKSI
         MVC   LCBDS1LR,WORKAREA+DS1LRECL
         MVI   DSNAME,X'04'        FOR FORMAT 4 DSCB
         MVC   DSNAME+1(43),DSNAME
         OBTAIN DSCB
         XR    R1,R1
         IC    R1,WORKAREA+DS4DEVDB
         STH   R1,LCBDIR
         L     R15,JFCBADRS
         LH    R1,JFCBLKSI(,R15)
         LTR   R1,R1
         BNZ   *+8
         LH    R1,WORKAREA+DS1BLKSI
         LA    R0,LCBLEN
         BAL   R14,GETBASE         WILL BE CONTIG
         LR    R4,R1
         XC    0(LCBLEN,R1),0(R1)
         BCT   R5,FI07A
         DROP  R4
FI07Z    EQU   *
         MVI   0(R4),X'FF'         SET END FLAG
         MVI   JFCBADRS,X'80'      END OF JFCB INIT
         MVC   DCBTIOT,WORK1       RESET TIOT PNTR
         BAL   R14,RESETHI
         SPACE
*---------------------------------------------------------------------*
*        BUILD THE SELECTED NAME TABLE
*---------------------------------------------------------------------*
         SPACE
         XC    NAMETBL2,NAMETBL2   SET PNTR TO NULL.
         TM    SWE,SWE0            SEL OR NOSEL                   .SEL.
         BZ    BLDSEL99            NOSEL, BYPASS SYSIN            .SEL.
         L     R2,TIOT             SCAN THE TIOT FOR MATCH
         LA    R2,24(R2)
         XR    R3,R3
BLDSEL01 EQU   *
         CLC   4(8,R2),DDIN
         BE    BLDSEL02            MATCH.
         CLI   0(R2),0             END OF TIOT?
         BE    BLDSEL99            YES, RETURN.
         IC    R3,0(R2)
         LA    R2,0(R2,R3)
         B     BLDSEL01
         SPACE
BLDSEL02 EQU   *
         LA    R8,SYSIN
         MVC   DCBDDNAM,DDIN
         OPEN  (SYSIN,INPUT)
         TM    DCBOFLGS,OFLGS      OPEN OK?
         BZ    BLDSEL99            NO, RETURN.
         LH    R0,SYSIN+DCBBLKSI-IHADCB  ALLOC SYSIN BUFFER
         BAL   R14,GETHI
         LR    R7,R1
         B     BLDSEL20
         SPACE
BLDSEL03 EQU   *
         LA    R5,80(,R5)
         LR    R3,R5
         SH    R6,=H'80'
         BNP   BLDSEL20
         LA    R2,72(,R3)          POINT AT END OF CARD.
BLDSEL04 EQU   *
         CLI   0(R3),C' '          BLANK?
         BE    BLDSEL03            YES, GO GET NEXT CARD.
         CR    R2,R3               END OF CARD?
         BL    BLDSEL03            YES, GO GET NEXT CARD.
         CLI   0(R3),C','          COMMA?
         BNE   BLDSEL05            NO.
         LA    R3,1(R3)            YES, SKIP OVER IT.
         B     BLDSEL04
         SPACE
BLDSEL05 EQU   *
         LA    R14,WORK1
         MVC   WORK1,=CL8' '
BLDSEL06 EQU   *
         CLI   0(R3),C' '          BLANK?
         BE    BLDSEL08            YES, END OF NAME
         CLI   0(R3),C','          COMMA?
         BE    BLDSEL08            YES, END OF NAME
         CR    R2,R3               END OF CARD?
         BL    BLDSEL08            YES, END OF NAME
         C     R14,=A(WORK1+8)     HAVE 8 BYTES BEEN PROCESSED?
         BNL   *+16                YES.
         IC    R15,0(R3)
         STC   R15,0(R14)
         LA    R14,1(R14)
         LA    R3,1(R3)
         B     BLDSEL06            GO GET NEXT CHAR.
         SPACE
BLDSEL08 EQU   *
         LA    R0,NAMTBLXX
         BAL   R14,GETBASE
         XC    0(NAMTBLXX,R1),0(R1)
         MVC   0(8,R1),WORK1
         TM    SWD,SWD0
         BO    BLDSEL04
         OI    SWD,SWD0
         ST    R1,NAMETBL2
         B     BLDSEL04
         SPACE
BLDSEL20 EQU   *
         READ  INDECB,SF,SYSIN,(R7),'S'
         CHECK INDECB
         LR    R5,R7
         L     R15,INDECB+16       CALC. LENGTH OF RECORD READ
         LH    R6,SYSIN+DCBBLKSI-IHADCB
         SH    R6,14(,R15)
         LA    R3,0(,R5)
         LA    R2,72(,R3)
         B     BLDSEL04
         SPACE
BLDSEL90 EQU   *
         TM    SWD,SWD0            ANY NAMES?
         BZ    BLDSEL95            NO
         LA    R0,8                YES, SET END FLAG
         BAL   R14,GETBASE
         MVI   0(R1),X'FF'
BLDSEL95 EQU   *
         CLOSE SYSIN
BLDSEL99 EQU   *
         BAL   R14,RESETHI
         L     R6,=A(PRMLST)
         BR    R6
         EJECT
BEGIN    EQU   *
         L     R2,ALCB
         USING LCB,R2
         TM    LCB,X'FF'
         BNM   ENDRUN
         BAL   R14,RESETLO
         BAL   R14,RESETHI
         XC    CURRENT2+4,CURRENT2+4
         MVC   CURRENT2,NAMETBL2
*        MVC   HEAD1DSN,LCBDSNAM                                 *.PRC.
*        MVC   HEAD1VOL,LCBVOLNO                                 *.PRC.
         MVC   HEDD1DSN+1(65),HEDD1DSN                            .PRC.
         MVC   HEDD1DSN+1(2),=C'--'                               .PRC.
         MVC   HEDD1DSN+4(44),LCBDSNAM                            .PRC.
         LA    R1,HEDD1DSN+4+43                                   .PRC.
         CLI   0(R1),C' '                                         .PRC.
         BNE   *+8                                                .PRC.
         BCT   R1,*-8                                             .PRC.
         MVC   2(2,R1),=C'--'                                     .PRC.
         MVC   5(4,R1),HEAD1C1R+3 'VOL='                          .PRC.
         MVC   9(6,R1),LCBVOLNO                                   .PRC.
*        MVC   HEAD2DSN,LCBDSNAM                                 *.PRC.
*        MVC   HEAD2VOL,LCBVOLNO                                 *.PRC.
         MVC   HEDD2DSN+4(58),HEDD1DSN+4                          .PRC.
         MVC   MAXDIR,LCBDIR       UPDATE FOR DIR READ
         LA    R1,LCBEND
         ST    R1,ALCB
         TM    LCBDS1DS,B'01000010' ONLY DSORG=PO/PS ARE VALID
         BNZ   BEGIN01
         OI    SWC,SWC1
         MVC   LINE1(L'LPDS11I),LPDS11I
         BAL   R10,PRNT
         LA    R1,4
         BAL   R14,SAVERC
         B     BEGIN
         SPACE
BEGIN01  EQU   *
         NI    SWC,255-SWC2        RESET DSORG=PS SWITCH
         TM    LCBDS1DS,B'01000000' IS THIS DSORG=PS?
         BZ    *+8                 NO.
         OI    SWC,SWC2            YES, FLAG IT.
         TM    SWD,SWD0            WERE NAMES SPECIFIED VIA SYSIN?
         BZ    BEGIN19             NO.
         TM    SWC,SWC2            IS THIS DSORG=PS?
         BO    BEGIN               YES, NOT PROCESSED ON SELECT.
BEGIN09  EQU   *
         L     R1,CURRENT2         RE-INIT THE NAME TBL2
         USING NAMTBL,R1
BEGIN10  EQU   *
         CLI   NAMTBL1,X'FF'       TEST FOR END
         BE    BEGIN19
         XC    NAMTBL2(12),NAMTBL2
         LA    R1,NAMTBLXX(,R1)
         B     BEGIN10
         SPACE
BEGIN19  EQU   *
         DROP  R1
         XR    R1,R1
         IC    R1,LCBJFCRF
         LTR   R1,R1
         BNZ   *+8
         IC    R1,LCBDS1RF
         STC   R1,SAVRECFM
         LH    R1,LCBJFCBL
         LTR   R1,R1
         BNZ   *+8
         LH    R1,LCBDS1BL
         STH   R1,SAVBLKSI
         ST    R1,BUFFER0          SET SIZE OF BUFFER(S)
         LH    R1,LCBJFCLR
         LTR   R1,R1
         BNZ   *+8
         LH    R1,LCBDS1LR
         STH   R1,SAVLRECL
         TM    SWD,SWD4+SWD5       RITS/CRBE/CRJE?
         BZ    *+8                 NO.
         OI    SWD,SWD7            YES, FLAG.
         DROP  R2
         SPACE
         LA    R8,SYSLIB
         LH    R15,SAVBLKSI        BLKSIZE SPECIFIED?
         LTR   R15,R15
         BNZ   *+24                YES.
         MVC   LINE1(L'LPDS06I),LPDS06I
         MVC   LINE1+L'LPDS06I(L'LPDS06IA),LPDS06IA
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
         TM    SAVRECFM,B'00000010'  MACH. CONTROL CHARS?
         BZ    *+30                NO.
         MVC   LINE1(L'LPDS06I),LPDS06I
         MVC   LINE1+L'LPDS06I(L'LPDS06I1),LPDS06I1
         MVC   LINE1+L'LPDS06I+L'LPDS06I1(L'LPDS06I0),LPDS06I0
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
         TM    SAVRECFM,B'11000000'
         BO    CHKLIB11
         TM    SAVRECFM,B'01001000'  VARIABLE SPANNED?
         BNO   CHKLIB11            NO
         MVC   LINE1(L'LPDS06I),LPDS06I
         MVC   LINE1+L'LPDS06I(L'LPDS06I2),LPDS06I2
         MVC   LINE1+L'LPDS06I+L'LPDS06I2(L'LPDS06I0),LPDS06I0
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
*---------------------------------------------------------------------*
*        RITS/CRBE
*---------------------------------------------------------------------*
         SPACE
CHKLIB11 EQU   *
         TM    SWD,SWD7            RITS/CRBE/CRJE SPECIFIED?
         BZ    CHKLIB15            NO.
         TM    SAVRECFM,B'11000000'  YES, CHECK PARMS
         BO    CHKLIB12            INVALID
         TM    SAVRECFM,B'10000000'
         BZ    CHKLIB12            INVALID
         LH    R15,SAVLRECL
         CH    R15,=H'88'
         BNE   *+8
         B     CHKLIB40
         SPACE
CHKLIB12 EQU   *
         NI    SWD,255-SWD7        TURN OFF RITS/CRBE
         OI    SWC,SWC1            FLAG REINIT SYSPRINT
         MVC   LINE1(L'LPDS07I),LPDS07I
         BAL   R10,PRNT
         LA    R1,4                RC=4
         BAL   R14,SAVERC
         SPACE
*---------------------------------------------------------------------*
*        CHECK RECFM TYPES
*---------------------------------------------------------------------*
         SPACE
CHKLIB15 EQU   *
         TM    SAVRECFM,B'11000000'    RECFM=U?
         BO    CHKLIB16
         TM    SAVRECFM,B'10000000'    RECFM=F?
         BO    CHKLIB17
         TM    SAVRECFM,B'01000000'    RECFM=V?
         BO    CHKLIB18
         MVC   LINE1+0(L'LPDS06I),LPDS06I
         MVC   LINE1+L'LPDS06I(L'LPDS06IB),LPDS06IB
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
*---------------------------------------------------------------------*
*        RECFM=U
*---------------------------------------------------------------------*
         SPACE
CHKLIB16 EQU   *
         LH    R15,SAVLRECL
         LTR   R15,R15
         BNZ   *+8
         LH    R15,SAVBLKSI
         CH    R15,SAVBLKSI
         BNH   *+8
         LH    R15,SAVBLKSI
         STH   R15,SAVLRECL
         B     CHKLIB40
         SPACE
*---------------------------------------------------------------------*
*        RECFM=F
*---------------------------------------------------------------------*
         SPACE
CHKLIB17 EQU   *
         TM    SAVRECFM,B'00010000'    BLOCKED?
         BO    *+16
         LH    R15,SAVBLKSI
         STH   R15,SAVLRECL
         B     CHKLIB40
         SPACE
         LH    R15,SAVLRECL
         LTR   R15,R15
         BNZ   *+8
         LH    R15,SAVBLKSI
         STH   R15,SAVLRECL
         B     CHKLIB40
         SPACE
*---------------------------------------------------------------------*
*        RECFM=V
*---------------------------------------------------------------------*
         SPACE
CHKLIB18 EQU   *
         TM    SAVRECFM,B'00100000'  TRACK OVERFLOW?
         BZ    CHKLIB40            NO.
         MVC   LINE1+0(L'LPDS06I),LPDS06I
         MVC   LINE1+L'LPDS06I(L'LPDS06I3),LPDS06I3
         MVC   LINE1+L'LPDS06I+L'LPDS06I3(L'LPDS06I0),LPDS06I0
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
*---------------------------------------------------------------------*
*        END OF LIB CHECK
*---------------------------------------------------------------------*
         SPACE
CHKLIB40 EQU   *
         LA    R8,SYSLIB
         SPACE
*---------------------------------------------------------------------*
*        REINIT DCB IF NECESSARY
*---------------------------------------------------------------------*
         SPACE
         CLC   SAVRECFM,DCBRECFM
         BE    BEGIN35
         CLOSE SYSLIB
         MVI   EXLST2,X'00'        SUPPRESS EXIT THIS TIME
         MVI   JFCBADRS,X'80'      SUPPRESS JFCB POINTER
         MVC   DCBRECFM,SAVRECFM   SET RECFM
         MVC   DCBLRECL,SAVLRECL   SET LRECL
         MVC   DCBBLKSI,DCBBLKSI   SET BLKSIZE
         OPEN  SYSLIB              RE-OPEN THE DATASETS
BEGIN35  EQU   *
         MVC   DCBLRECL,SAVLRECL   SET THE LRECL
         MVC   DCBBLKSI,SAVBLKSI   SET THE BLKSIZE
         XC    TTRK(2),TTRK        POINT AT NEW DIRECTORY
         MVI   TTRK+2,1
         XC    NAMETBL1,NAMETBL1
         NI    SWE,255-SWE2        RESET SPF-THIS-PDS SWITCH      .SPF.
         TM    SWC,SWC2            IS THIS DSORG=PS?
         BO    BEGIN9              YES, SKIP DIR. BUILD
         SPACE
*---------------------------------------------------------------------*
*        ALLOCATE THE DIRECTORY-READ WORKAREA (CHAN. PROGS., ETC.)
*---------------------------------------------------------------------*
         SPACE
         LH    R2,MAXDIR
         LR    R0,R2
         MH    R2,=H'8'
         LA    R2,16(,R2)          C.P. SIZE
         MH    R0,=H'272'          DATA AREA SIZE
         AR    R0,R2               WORKAREA SIZE
         BAL   R14,GETHI           GET SOME CORE
         ST    R1,WORK1            AREA FOR THE C.P.
         AR    R2,R1
         ST    R2,WORK1+4          FOR THE DATA
         SPACE
*---------------------------------------------------------------------*
*        BUILD THE CHANNEL PROGRAM
*---------------------------------------------------------------------*
         SPACE
         LH    R15,MAXDIR
         XC    0(16,R1),0(R1)      BUILD THE SHA AND TIC
         LA    R0,CCHHR
         ST    R0,0(,R1)
         MVI   0(R1),X'39'         ...SHA
         MVI   4(R1),X'40'
         MVI   7(R1),4
         ST    R1,8(,R1)
         MVI   8(R1),X'08'         ...TIC
         MVI   12(R1),X'40'
         LA    R1,16(,R1)
         LA    R14,272             ..SIZE OF DATA RECORD
BLDNAM10 EQU   *
         XC    0(8,R1),0(R1)
         ST    R2,0(,R1)
         MVI   0(R1),X'1E'         READ CKD
         MVI   4(R1),X'60'
         STH   R14,6(,R1)
         LA    R1,8(,R1)
         AR    R2,R14
         BCT   R15,BLDNAM10
         SH    R1,=H'4'
         NI    0(R1),X'BF'         TURN OFF CHAINING
         L     R1,WORK1
         ST    R1,ACP
         SPACE 3
BLDNAM20 EQU   *
         STM   R14,R12,12(R13)     SAVE REGS FOR TTR CNVT
         L     R0,TTRK
         LH    R1,TTRK             UPDATE FOR NEXT TIME
         LA    R1,1(,R1)
         STH   R1,TTRK
         L     R1,SYSLIB+DCBDEBAD-IHADCB
         LA    R2,MBB
         L     R15,CVTPTR
         L     R15,CVTPCNVT(,R15)
         LR    R3,R13              SAVE 13 OVER CALL
         BALR  R14,R15
         LR    R13,R3              NOW RESTORE 13
         LM    R14,R12,12(R13)     AND THEN THE REST
         LH    R15,MAXDIR          NOW CLEAR THE DATA AREA
         L     R1,WORK1+4
BLDNAM22 EQU   *
         XC    0(20,R1),0(R1)
         LA    R1,272(,R1)
         BCT   R15,BLDNAM22
         XC    ECB,ECB
         LA    R10,BLDNAM23
         EXCP  IOB
         WAIT  1,ECB=ECB
BLDNAM23 EQU   *
         CLI   ECB,X'7F'           I/O OK
         BE    BLDNAM27
         CLI   ECB,X'42'
         BE    BLDNAM90            I/O ERROR OR BAD FORMAT
         SPACE
*---------------------------------------------------------------------*
*        SHORT TRACK, FIND THE END.
*---------------------------------------------------------------------*
         SPACE
         LH    R15,MAXDIR
         L     R1,WORK1+4
         XR    R5,R5
BLDNAM25 EQU   *
         CLC   =XL5'0',0(R1)
         BE    BLDNAM28
         CLC   =H'0',6(R1)
         BE    BLDNAM28
         CLC   =X'0100',6(R1)
         BNE   BLDNAM90            BAD DIR FORMAT
         LA    R1,272(,R1)
         LA    R5,1(,R5)
         BCT   R15,BLDNAM25
BLDNAM27 EQU   *
         LH    R5,MAXDIR
BLDNAM28 EQU   *
         L     R4,WORK1+4
BLDNAM30 EQU   *
         LA    R3,18(,R4)
         MVC   WORK2(2),16(R4)
         LH    R2,WORK2
         SH    R2,=H'2'
BLDNAM36 EQU   *
         IC    R7,11(,R3)
         N     R7,=F'31'
         SLL   R7,1
         CH    R7,=H'30'           COULD THIS BE SPF STATS        .SPF.
         BNE   BLDNOSPF            NO, BRANCH                     .SPF.
         TM    11(R3),X'60'        ANY TTR'S IN USERDATA          .SPF.
         BNZ   BLDNOSPF            YES, NOT SPF STATS             .SPF.
         OI    SWE,SWE2+SWE3       SPF STATS FOUND                .SPF.
BLDNOSPF EQU   *                                                  .SPF.
         LA    R6,DIRUSER-DIRNAME(,R7)
         LA    R0,DIRNAME-DIR(,R6)
         BAL   R14,GETLOW
         XC    0(DIRLEN,R1),0(R1)
         OC    NAMETBL1,NAMETBL1
         BNZ   *+8
         ST    R1,NAMETBL1
         STH   R7,DIRUSERL-DIR(,R1)
         BCTR  R6,0
         EX    R6,BLDNAMMV
         CLI   0(R3),X'FF'         TEST FOR END
         BE    BLDNAM95
         LA    R6,1(,R6)
         AR    R3,R6
         SR    R2,R6
         BP    BLDNAM36
         LA    R4,272(,R4)
         SH    R5,=H'1'
         BP    BLDNAM30
         B     BLDNAM20
         SPACE
BLDNAMMV MVC   DIRNAME-DIR(*-*,R1),0(R3)
BLDNAM90 MVC   LINE1(L'LPDS08I),LPDS08I
         BAL   R10,PRNT
         B     TERMINAT
         SPACE
*---------------------------------------------------------------------*
*        END OF DIRECTORY.
*---------------------------------------------------------------------*
         SPACE
BLDNAM95 EQU   *
         MVC   CURRENT1,NAMETBL1
BEGIN9   EQU   *
         LA    R8,SYSLIB
         OI    SWD,SWD6            FLAG FIRST EJECT ON LIST
         LH    R1,LINEMAX          RE-INIT SYSPRINT PAGE
         STH   R1,LINECNT1
         SPACE
*---------------------------------------------------------------------*
*        ALLOCATE THE DATA BUFFERS
*---------------------------------------------------------------------*
         SPACE
         BAL   R14,RESETHI
         L     R0,BUFFER0
         BAL   R14,GETHI
         ST    R1,BUFFER1
         CLI   SAVBUFNO,2
         BL    BEGIN9A
         L     R0,BUFFER0
         BAL   R14,GETHI
         ST    R1,BUFFER2
BEGIN9A  EQU   *
         TM    SWC,SWC2            IS THIS DSORG=PS?
         BZ    MAIN00              NO, GO PROCESS A PDS LIBRARY.
         SPACE
*---------------------------------------------------------------------*
*        INIT FOR DSORG=PS
*---------------------------------------------------------------------*
         SPACE
         NI    SWD,255-SWD7        NO CRJE, ETC.
         LA    R0,DIRLEN
         BAL   R14,GETLOW
         XC    0(DIRLEN,R1),0(R1)
         LR    R4,R1
         USING DIR,R4
         TM    SWA,SWA0            LIST?
         BZ    MAIN31              NO, GO PROCESS.
         MVC   HEAD2NAM,NAME
         MVI   LINE2,C'+'
         BAL   R10,LOUT
         MVC   DIRPG1,PAGENUM2
         B     MAIN31              GO PROCESS DSORG=PS
         SPACE
MAIN00   EQU   *
         NI    SWD,255-SWD1        TURN OFF ALIAS SWITCH
         TM    SWD,SWD0            SYSIN NAMES SPECIFIED?
         BZ    MAIN10              NO.
         TM    SWD,SWD2            SELECT OF EXCLUDE?
         BNZ   MAIN10              NOT SELECT.
         SPACE
*---------------------------------------------------------------------*
*        GET NEXT NAME FROM NAMETBL2
*---------------------------------------------------------------------*
         SPACE
         L     R2,CURRENT2
         USING NAMTBL,R2
         CLI   NAMTBL,X'FF'        END OF TABLE?
         BE    ENDLIB              YES.
         MVC   NAME,NAMTBL1
         LA    R1,NAMTBLXX(R2)
         STM   R1,R2,CURRENT2
         SPACE
*---------------------------------------------------------------------*
*        SEARCH NAMETBL1 FOR ENTRY.
*---------------------------------------------------------------------*
         SPACE
         L     R4,NAMETBL1
         USING DIR,R4
MAIN02   EQU   *
         CLI   DIRNAME,X'FF'       END?
         BE    MAIN00              YES, MEMBER NOT FOUND.
         CLC   NAMTBL1,DIRNAME     IS THIS IT?
         BE    MAIN04              YES, FOUND IT.
         LH    R15,DIRUSERL        UPDATE POINTER AND TRY NEXT ENTRY
         LA    R4,DIRUSER(R15)
         B     MAIN02
         SPACE
MAIN04   EQU   *
         ST    R4,NAMTBL2          SAVE POINTER
         LA    R1,DIRNAME          POINT TO DIR ENTRY AREA
         B     MAIN12
         DROP  R2
         SPACE
*---------------------------------------------------------------------*
*        GET NEXT ENTRY FROM NAMETBL1
*---------------------------------------------------------------------*
         SPACE
MAIN10   EQU   *
         L     R4,CURRENT1
         USING DIR,R4
         CLI   DIRNAME,X'FF'       TEST FOR END
         BE    ENDLIB
         MVC   NAME,DIRNAME        SAVE NAME FOR LATER PROCESSING
         LH    R15,DIRUSERL
         LA    R1,DIRNAME
         LA    R2,DIRUSER(R15)
         ST    R2,CURRENT1
         TM    SWD,SWD0            SYSIN NAMES SPECIFIED (EXCLUDE)?
         BZ    MAIN12              NO
         L     R2,NAMETBL2         CHECK FOR EXCLUDE
         USING NAMTBL,R2
MAIN11   EQU   *
         CLI   NAMTBL,X'FF'        TEST FOR END OF EXCLUDED LIST
         BE    MAIN12              NOT EXCLUDED, GO PROCESS THE MEMBER
         CLC   NAMTBL1,DIRNAME
         BE    MAIN10              NAME MATCH..THIS MEMBER EXCLUDED.
         LA    R2,NAMTBLXX(,R2)
         B     MAIN11
         DROP  R2
         SPACE 2
MAIN12   EQU   *
         TM    DIRTTR+3,ALIAS      IS THIS AN ALIAS?
         BZ    MAIN20              NO, CONTINUE.
         SPACE
*---------------------------------------------------------------------*
*        ALIAS ENTRY ... FIND PRIME ENTRY (IF IT EXISTS)
*---------------------------------------------------------------------*
         SPACE
         L     R2,NAMETBL1
MAIN14   EQU   *
         CLI   DIRNAME-DIR(R2),X'FF'
         BE    MAIN20              ..END TBL, IGNORE ALIAS
         CLC   DIRTTR(3),DIRTTR-DIR(R2)
         BNE   MAIN14A
         TM    DIRTTR+3-DIR(R2),ALIAS
         BZ    MAIN16              PRIME ENTRY FOUND FOR ALIAS
MAIN14A  EQU   *
         LH    R15,DIRUSERL-DIR(R2)
         LA    R2,DIRUSER-DIR(R2,R15)
         B     MAIN14
         SPACE
*---------------------------------------------------------------------*
*        PRIME ENTRY FOUND FOR ALIAS
*---------------------------------------------------------------------*
         SPACE
MAIN16   EQU   *
         OI    DIRFLAGS,B'11000000'    SET ALIAS FLAG
         TM    SWD,SWD0            SELECTED NAMES SPECIFIED?
         BO    MAIN20              YES, CONTINUE.
         LH    R1,MEMCNT           UPDATE MEMBER COUNTER
         LA    R1,1(R1)
         STH   R1,MEMCNT
         B     MAIN00
         SPACE
*---------------------------------------------------------------------*
*        MEMBER PROCESSING
*---------------------------------------------------------------------*
         SPACE
MAIN20   EQU   *
         LH    R1,MEMCNT           UPDATE MEMBER COUNTER
         LA    R1,1(R1)
         STH   R1,MEMCNT
         OI    DIRFLAGS,B'10000000'    FLAG MEMBER 'PROCESSED'
         TM    SWA,SWA0            LIST?
         BZ    MAIN21              NO.
         TM    SWA,SWA5            IS IT EJECT FORMAT
         BO    MAIN20D             YES.
         MVC   LINE2(8),=C'0MEMBER='
         MVC   LINE2+8(8),NAME
         BAL   R10,LOUT
         MVC   HEAD2NAM,NAME       INIT LISTING FOR MEMBER OUTPUT
         MVC   DIRPG1,PAGENUM2     SAVE PAGE NUMBER
         MVI   LINE2,C'0'
         B     MAIN21
         SPACE
MAIN20D  EQU   *
         OI    SWD,SWD6            FORCE EJECT FORMAT
         MVC   HEAD2NAM,NAME       INIT LISTING FOR MEMBER OUTPUT
         MVI   LINE2,C'+'
         BAL   R10,LOUT
         MVC   DIRPG1,PAGENUM2     SAVE PAGE NUMBER
MAIN21   EQU   *
         TM    SWA,SWA2            LIST DIR ONLY?
         BO    MAIN00              YES, SKIP PROCESSING
         TM    SWA,SWA1+SWA3       DECK OUTPUT WITH UPDTE
         BNO   MAIN30              NO
         MVC   CARD+50(L'HEAD1DAT),HEAD1DAT
         MVC   CARD+50+L'HEAD1DAT(L'HEAD1TIM),HEAD1TIM
         LH    R15,DIRUSERL        ANY USER INFO?
         CH    R15,=H'4'           (MUST BE 4 BYTES)
         BNE   *+12                NO, THERE NO SSI     (WAS BL)  .SPF.
         TM    SWA,SWA6            SSI SPECIFIED?
         BO    MAIN24              YES.
         MVC   CARD(L'UPDTE1),UPDTE1  CC WITH NO SSI
         MVC   CARD+L'UPDTE1(L'NAME),NAME
         CH    R15,=H'30'          ARE SPF STATS PRESENT          .SPF.
         BNE   MAIN24A             NO, BRANCH                     .SPF.
         TM    SWE,SWE1+SWE2       SPF IN THIS PDS                .SPF.
         BNO   MAIN24A             NO, BRANCH                     .SPF.
         LA    R15,L'UPDTE1+9+CARD WHERE TO PUT THEM              .SPF.
         MVI   0(R15),C'-'         HYPHEN TO BE PROPOGATED        .SPF.
         MVC   1(49,R15),0(R15)    FILL AREA WITH HYPHENS         .SPF.
         SLR   R0,R0               CLEAR FOR INSERT               .SPF.
         IC    R0,DIRUSER          GET V OF V.M                   .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  0(2,R15),WORK1+6(2)                                .SPF.
         IC    R0,DIRUSER+1        GET M OF V.M                   .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  2(2,R15),WORK1+6(2)                                .SPF.
         UNPK  05(5,R15),DIRUSER+4(4) YYDDD CREATED               .SPF.
         UNPK  11(5,R15),DIRUSER+8(4) YYDDD LAST MODIFIED         .SPF.
         MVO   WORK1(3),DIRUSER+12(2) HHMM   LAST MODIFIED        .SPF.
         OI    WORK1+2,X'0F'                                      .SPF.
         UNPK  17(4,R15),WORK1(3)                                 .SPF.
         LH    R0,DIRUSER+14       CURRENT SIZE                   .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  22(5,R15),WORK1+5(3)                               .SPF.
         LH    R0,DIRUSER+16       INITIAL SIZE                   .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  28(5,R15),WORK1+5(3)                               .SPF.
         LH    R0,DIRUSER+18       LINES MODIFIED                 .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  34(5,R15),WORK1+5(3)                               .SPF.
         MVC   40(10,R15),DIRUSER+20   USER ID                    .SPF.
         B     MAIN24A
*MAIN24  MVC   CARD(L'UPDTE2),UPDTE2  CC WITH SSI                *.PRC.
*        MVC   CARD+L'UPDTE2(L'NAME),NAME                        *.PRC.
*        LA    R15,11+CARD          FORMAT SSI                   *.PRC.
*                  NEW CODE FOR ADD NAME=MEMBER,SSI=XXXXXXXX      .PRC.
*                  INSTEAD OF   ADD SSI=XXXXXXXX,NAME=MEMBER      .PRC.
MAIN24   EQU   *                                                  .PRC.
         MVC   CARD(L'UPDTE1),UPDTE1                              .PRC.
         MVC   CARD+L'UPDTE1(L'NAME),NAME                         .PRC.
         LA    R15,CARD+L'UPDTE1+7 LAST BYTE OF NAME              .PRC.
         CLI   0(R15),C' '         LOOK FOR LAST NONBLANK         .PRC.
         BNE   *+8                 BRANCH IF FOUND                .PRC.
         BCT   R15,*-8             LOOP TO CLI                    .PRC.
         MVC   1(5,R15),=C',SSI='  APPEND KEYWORD                 .PRC.
         LA    R15,6(,R15)         POINT PAST KEYWORD             .PRC.
         LA    R0,4
         LA    R1,DIRUSER
         BAL   R10,HEXCON
MAIN24A  EQU   *
         BAL   R10,PUNCHIT
         SPACE
*---------------------------------------------------------------------*
*        INIT FOR READING
*---------------------------------------------------------------------*
         SPACE
         USING DIR,R4
MAIN30   EQU   *
         MVC   TTRK(3),DIRTTR
MAIN31   EQU   *
         FIND  SYSLIB,TTRK,C
         LM    R2,R3,BUFFER1       INIT BUFFERS
         STM   R2,R3,BFRS
         XR    R5,R5               CLEAR CURRENT MEM REC CNTR
         CLI   SAVBUFNO,2          DOUBLE BUFFERING?
         BNE   MAIN32              NO.
         XC    PDSDECB,PDSDECB     YES, ISSUE FIRST READ.
         READ  PDSDECB,SF,(R8),(R2),MF=E
         SPACE
*---------------------------------------------------------------------*
*        READ IN NEXT BLOCK
*---------------------------------------------------------------------*
         SPACE
MAIN32   EQU   *
         CLI   SAVBUFNO,2          DOUBLE BUFFERING?
         BE    MAIN34              YES.
         L     R2,BFRS             NO...ISSUE READ
         XC    PDSDECB,PDSDECB     CLEAR ECB
         READ  PDSDECB,SF,(R8),(R2),'S'
MAIN34   EQU   *
         LA    R10,MAIN65 .. SET E.O.F. ADDR
         CHECK PDSDECB
         L     R15,PDSDECB+16      COMPUTE LEN OF REC READ
         LH    R6,DCBBLKSI
         SH    R6,14(R15)
         L     R7,BFRS             LOAD PNTR TO DATA
         CLI   SAVBUFNO,2          DOUBLE BUFFERING?
         BNE   MAIN36              NO.
         L     R2,BFRS+4           YES, INIT NEXT READ
         ST    R7,BFRS+4
         ST    R2,BFRS
         XC    PDSDECB,PDSDECB     CLEAR ECB
         READ  PDSDECB,SF,(R8),(R2),MF=E
MAIN36   EQU   *
         TM    SAVRECFM,B'10000000'  RECFM U OR F?
         BO    MAIN38              YES.
         LH    R6,0(R7)            NO, MUST BE V ...
         LA    R7,4(R7)            PROCESS BLOCK DESCRIPTOR
         SH    R6,=H'4'
MAIN38   EQU   *
MAIN40   EQU   *                   RITS/CRBE/CRJE?
         TM    SWD,SWD7            RITS/CRBE/CRJE?
         BZ    MAIN50              NO
         SPACE
*---------------------------------------------------------------------*
*        PROCESS A RITS/CRBE RECORD
*---------------------------------------------------------------------*
         SPACE
         TM    SWA,SWA0            LIST?
         BZ    MAIN45              NO.
         TM    SWA,SWA4            MAXLIST SPECIFIED?
         BZ    MAIN42              NO
         CH    R5,MAXLIST          YES, TEST FOR LIMIT.
         BNL   MAIN45              LIMIT EXCEEDED.
MAIN42   EQU   *
         MVC   LINE2+1(8),0(R7)
         MVC   LINE2+11(80),8(R7)
         BAL   R10,LOUT            YES, OUTPUT FORMATTED LINE
MAIN45   EQU   *
         TM    SWA,SWA1            DECK?
         BZ    MAIN64              NO.
         MVC   CARD,8(R7)
         BAL   R10,PUNCHIT         YES, OUTPUT CARD IMAGE
         B     MAIN64
         SPACE
*---------------------------------------------------------------------*
*        'LIST' PROCESSING
*---------------------------------------------------------------------*
         SPACE
MAIN50   EQU   *
         TM    SWA,SWA0            LIST?
         BZ    MAIN60              NO.
         TM    SWA,SWA4            MAXLIST SPECIFIED?
         BZ    MAIN50A             NO
         CH    R5,MAXLIST          YES, AT LIMIT?
         BNL   MAIN60              YES, SKIP LISTING
MAIN50A  EQU   *
         TM    SAVRECFM,B'11000000'    RECFM=U?
         BO    *+12                YES
         TM    SAVRECFM,B'01000000'    RECFM=V?
         BO    MAIN51              YES
         LH    R3,DCBLRECL         RECFM = F OR U.
         LA    R2,0(R7)
         B     MAIN52
         SPACE
MAIN51   EQU   *
         MVC   DCBLRECL,0(R7)
         LA    R2,4(R7)
         LH    R3,DCBLRECL
         SH    R3,=H'4'
MAIN52   EQU   *
         TM    SWB,SWB1            HEXOUT?
         BO    MAIN56              YES.
         TM    SWB,SWB3            IS NUM SPECIFIED?
         BO    MAIN57              YES.
MAIN53   EQU   *
         LR    R15,R3
         CH    R3,=H'116'
         BNH   *+8
         LA    R15,116
         BCTR  R15,0
         LA    R1,LINE2+1
         EX    R15,VARMVC1
MAIN54   EQU   *
         LA    R2,116(R2)          OUTPUT OTHER LINES
         SH    R3,=H'116'
         BNP   MAIN59              DONE IF NO MORE DATA
         MVI   LINE2+120,C'*'
         TM    SWA,SWA7            TRUNC?
         BO    MAIN59              YES, QUIT HERE
         BAL   R10,LOUT            OUTPUT FORMATTED LINE
         B     MAIN53              NO, LOOP TO CONTINUE OUTPUT
         SPACE
MAIN56   EQU   *
         LA    R15,LINE2+5         OUTPUT LINE IN HEX
         LR    R0,R3
         CH    R3,=H'50'           FIFTY BYTES PER LINE
         BNH   *+8
         LA    R0,50
         LR    R1,R2
         BAL   R10,HEXCON
         LA    R2,50(R2)           OUTPUT OTHER LINES
         SH    R3,=H'50'
         BNP   MAIN59              DONE
         MVI   LINE2+120,C'*'      FLAG LINE CONTINUATION
         TM    SWA,SWA7            IS TRUNC SPECIFIED?
         BO    MAIN59              YES, QUIT.
         BAL   R10,LOUT            OUTPUT FORMATTED LINE
         B     MAIN56              LOOP
         SPACE
MAIN57   EQU   *
         SH    R3,=H'8'
         TM    SAVRECFM,B'10000000' IS IT RECFM=U/F/FB?
         BO    MAIN57A             YES.
         MVC   LINE2+1(8),0(R2)    NO, RECFM=V/VB
         LA    R2,8(0,R2)
         B     MAIN57B
         SPACE
MAIN57A  EQU   *
         LA    R14,0(R2,R3)
         MVC   LINE2+1(8),0(R14)
MAIN57B  EQU   *
         LA    R1,LINE2+10
         LR    R15,R3
         CH    R15,=H'108'
         BNH   *+8
         LA    R15,108
         BCTR  R15,0
         EX    R15,VARMVC1
         LA    R2,106(0,R2)
         SH    R3,=H'106'
         BNP   MAIN59
         MVI   LINE2+120,C'*'
         TM    SWA,SWA7
         BO    MAIN59
         BAL   R10,LOUT
MAIN58   EQU   *
         LR    R15,R3
         LA    R1,LINE2+10
         CH    R15,=H'106'
         BNH   *+8
         LA    R15,106
         BCTR  R15,0
         EX    R15,VARMVC1
         LA    R2,106(0,R2)
         SH    R3,=H'106'
         BNP   MAIN59
         MVI   LINE2+120,C'*'
         BAL   R10,LOUT            OUTPUT FORMATTED LINE
         B     MAIN58
         SPACE
MAIN59   EQU   *
         BAL   R10,LOUT            OUTPUT FORMATTED LINE.
         SPACE
*---------------------------------------------------------------------*
*        'DECK' PROCESSING
*---------------------------------------------------------------------*
         SPACE
MAIN60   EQU   *
         TM    SWA,SWA1            DECK?
         BZ    MAIN64              NO.
         TM    SAVRECFM,B'11000000'    RECFM=U?
         BO    *+12                YES
         TM    SAVRECFM,B'01000000'    RECFM=V?
         BO    MAIN61              YES
         LH    R3,DCBLRECL         RECFM = U OR F
         LA    R2,0(R7)
         B     MAIN62
         SPACE
MAIN61   EQU   *
         MVC   DCBLRECL,0(R7)      RECFM=V/VB
         LA    R2,4(R7)
         LH    R3,DCBLRECL
         SH    R3,=H'4'
MAIN62   EQU   *
         LR    R15,R3
         CH    R3,=H'80'
         BNH   *+8
         LA    R15,80
         BCTR  R15,0
         EX    R15,VARMVC3
         TM    SWA,SWA3            UPDTE                          .PRC.
         BNO   MAIN62A                                            .PRC.
         CH    R3,=H'80'           IS LRECL=80                    .PRC.
         BNE   MAIN62A                                            .PRC.
         CLC   CARD(2),=C'./'      IS THIS AN UPDTE STATEMENT     .PRC.
         BNE   MAIN62A                                            .PRC.
         MVC   CARD(2),UPDTESUB    YES, SUBSTITUTE CHARS          .PRC.
MAIN62A  EQU   *                                                  .PRC.
         BAL   R10,PUNCHIT
         SPACE
*---------------------------------------------------------------------*
*        END OF LOGICAL RECORD
*---------------------------------------------------------------------*
         SPACE
MAIN64   EQU   *
         LA    R5,1(R5)            UPDATE REC COUNT
         TM    SAVRECFM,B'11000000'    RECFM=U?
         BO    MAIN32              YES, GO GET NEXT BLOCK.
         TM    SAVRECFM,B'01000000'  RECFM=V?
         BZ    *+10                NO
         MVC   DCBLRECL,0(R7)      YES, USE RECORD DESC. LEN
         AH    R7,DCBLRECL         UPDATE BUFFER POINTER
         SH    R6,DCBLRECL         UPDATE BYTES COUNT
         BP    MAIN40              CONTINUE WITH THIS BLOCK
         B     MAIN32              GO GET NEXT BLOCK
         SPACE
*---------------------------------------------------------------------*
*        END OF MEMBER OR SDS
*---------------------------------------------------------------------*
         SPACE
MAIN65   EQU   *
         TM    SWC,SWC2            IS THIS DSORG=PS?
         BO    MAIN70              YES, GO PROCESS IT.
         ST    R5,WORK2
         MVC   DIRCRDCT,WORK2
         TM    SWD,SWD0            SYSIN NAMES SPECIFIED?
         BZ    MAIN66              NO
         TM    SWD,SWD2            SELECT MEMBERS?
         BNZ   MAIN66              NO.
         L     R2,CURRENT2+4       YES, UPDATE COUNTS
         USING NAMTBL,R2
         MVC   NAMTBL4,DIRPG1
         MVC   NAMTBL3,DIRCRDCT
         DROP  R2
MAIN66   EQU   *
         CVD   R5,WORK2
         AL    R5,RECORDS          UPDATE TOTAL REC COUNT
         ST    R5,RECORDS
         TM    SWA,SWA0            LIST?
         BZ    MAIN67              NO.
         MVI   LINE2,C'*'          PAD LINE WITH ASTERICKS
         MVC   LINE2+1(L'LINE2-1),LINE2
         MVC   LINE2(MSG2L),MSG2
         ED    LINE2+L'MSG2(L'MSG2A),WORK2+5
         BAL   R10,LOUT
MAIN67   EQU   *
         B     MAIN00
         SPACE
*---------------------------------------------------------------------*
*        END OF DSORG=PS DATASET.
*---------------------------------------------------------------------*
         SPACE
MAIN70   EQU   *
         ST    R5,RECORDS
         MVC   LINE1+6(8),=8C'*'
         LH    R1,DIRPG1
         CVD   R1,WORK1
         MVC   WORK2(8),PAGEPAT
         ED    WORK2,WORK1+4
         MVC   LINE1+15(6),WORK2+2
         BAL   R10,PRNT
         BAL   R10,PRNT
         CVD   R5,WORK2
         TM    SWA,SWA0            LIST?
         BZ    MAIN72              NO.
         MVI   LINE2,C'*'          PAD LINE WITH ASTERICKS
         MVC   LINE2+1(L'LINE2-1),LINE2
         MVC   LINE2(MSG9L),MSG9
         ED    LINE2+L'MSG9(L'MSG9A),WORK2+5
         BAL   R10,LOUT
MAIN72   EQU   *
         MVI   MEMCNT+1,1          "SDS" IS ONE MEMBER
         CVD   R5,WORK2
         MVC   LINE1(MSG9L),MSG9
         MVI   LINE1,C' '
         ED    LINE1+L'MSG9(L'MSG9A),WORK2+5
         BAL   R10,PRNT
         A     R5,TOTALREC
         ST    R5,TOTALREC
         B     ENDLIB90
         EJECT
*----------------------------------------------------------------------
*        END-OF-LIBRARY
*----------------------------------------------------------------------
ENDLIB   EQU   *
         LA    R8,SYSLIB
         TM    SWD,SWD0            SELECT OR EXCLUDE SPECIFIED?
         BZ    ENDLIB05            NO
         TM    SWD,SWD2            SELECT SPECIFIED?
         BZ    ENDLIB20            YES.
ENDLIB05 EQU   *
         MVC   CURRENT1,NAMETBL1
         USING DIR,R4
ENDLIB10 EQU   *
         L     R4,CURRENT1
         CLI   DIRNAME,X'FF'
         BE    ENDLIB80
         LH    R15,DIRUSERL
         LA    R1,DIRUSER(R15)
         ST    R1,CURRENT1
         TM    SWD,SWD0+SWD2       WAS SYSIN-EXCLUDE SPECIFIED?
         BNO   ENDLIB12            NO
         TM    DIRFLAGS,B'10000000'  ..WAS THIS MEMBER SPECIFIED?
         BZ    ENDLIB10            NO, SKIP IT.
ENDLIB12 EQU   *
         BAL   R10,LSTDIR
ENDLIB14 EQU   *
         TM    DIRTTR+3,ALIAS      IS THIS AN ALIAS?
         BZ    ENDLIB10            NO
         MVC   LINE1+L'CAPTIONS(L'MSG4),MSG4
         MVC   LINE1+L'CAPTIONS+L'MSG4(8),=8C'?'
         L     R1,NAMETBL1
ENDLIB15 EQU   *
         CLI   DIRNAME-DIR(R1),X'FF'
         BE    ENDLIB18
         CLC   DIRTTR(3),DIRTTR-DIR(R1)
         BE    ENDLIB17
ENDLIB16 EQU   *
         LH    R15,DIRUSERL-DIR(R1)
         LA    R1,DIRUSER-DIR(R15,R1)
         B     ENDLIB15
ENDLIB17 EQU   *
         TM    DIRTTR-DIR+3(R1),ALIAS
         BO    ENDLIB16
         MVC   LINE1+L'CAPTIONS+L'MSG4(8),DIRNAME-DIR(R1)
ENDLIB18 EQU   *
         BAL   R10,PRNT
         B     ENDLIB10
ENDLIB20 EQU   *
         MVC   CURRENT2,NAMETBL2
         USING NAMTBL,R2
ENDLIB22 EQU   *
         L     R2,CURRENT2
         CLI   NAMTBL,X'FF'
         BE    ENDLIB80
         LA    R1,NAMTBLXX(R2)
         STM   R1,R2,CURRENT2
         L     R4,NAMTBL2          GET PNTR TO DIR AREA
         LTR   R4,R4               IS THERE ONE?
         BNZ   ENDLIB30            YES.
         MVC   LINE1+6(8),NAMTBL1  NO, ISSUE MSG
         MVC   LINE1+16(L'MSG3),MSG3
         BAL   R10,PRNT
         B     ENDLIB22
         SPACE
ENDLIB30 EQU   *                   MEMBER FOUND, LIST INFO.
         MVC   DIRPG1,NAMTBL4
         MVC   DIRCRDCT,NAMTBL3
         BAL   R10,LSTDIR
ENDLIB34 EQU   *
         TM    DIRFLAGS,B'11000000' IS THIS PROCESSED ALIAS?
         BNO   ENDLIB22            NO
         MVC   LINE1+L'CAPTIONS(L'MSG4),MSG4
         MVC   LINE1+L'CAPTIONS+L'MSG4(8),=8C'?'
         L     R1,NAMETBL1
ENDLIB35 EQU   *
         CLI   DIRNAME-DIR(R1),X'FF'
         BE    ENDLIB38
         CLC   DIRTTR(3),DIRTTR-DIR(R1)
         BE    ENDLIB37
ENDLIB36 EQU   *
         LH    R15,DIRUSERL-DIR(R1)
         LA    R1,DIRUSER-DIR(R15,R1)
         B     ENDLIB35
         SPACE
ENDLIB37 EQU   *
         TM    DIRTTR-DIR+3(R1),ALIAS
         BO    ENDLIB36
         MVC   LINE1+L'CAPTIONS+L'MSG4(8),DIRNAME-DIR(R1)
ENDLIB38 EQU   *
         BAL   R10,PRNT
         B     ENDLIB22
         SPACE
*---------------------------------------------------------------------*
*        ISSUE END OF LIBRARY MESSAGE
*---------------------------------------------------------------------*
         SPACE
ENDLIB80 EQU   *
         MVC   LINE1(MSG1L),MSG1
         LH    R15,MEMCNT
         CVD   R15,WORK1
         ED    LINE1+L'MSG1(L'MSG1A),WORK1+5
         L     R15,RECORDS
         CVD   R15,WORK1
         AL    R15,TOTALREC
         ST    R15,TOTALREC
         ED    LINE1+L'MSG1+L'MSG1A+L'MSG1AX(L'MSG1B),WORK1+4
         BAL   R10,PRNT
ENDLIB90 EQU   *
         XC    RECORDS,RECORDS
         XC    MEMCNT,MEMCNT
         IC    R15,TTRK+3
         LA    R15,1(R15)
         STC   R15,TTRK+3
         B     BEGIN
         SPACE
*---------------------------------------------------------------------*
*        END-OF-RUN
*---------------------------------------------------------------------*
         SPACE
ENDRUN   EQU   *
         TM    SWB,SWB0            DEBUG?
         BO    ENDRUN10            YES, BYPASS FREE CORE
         SPACE
*---------------------------------------------------------------------*
*        FREE WORKAREA
*---------------------------------------------------------------------*
         SPACE
         OC    COR2,COR2           MAKE SURE CORE WAS GOTTEN
         BZ    ENDRUN10            NOT GOTTEN
         FREEMAIN V,A=COR2
ENDRUN10 EQU   *
         TM    SWC,SWC3            TERMINATE MODE?
         BO    ENDRUN11            YES.
         MVC   LINE1(L'ENDMSG0),ENDMSG0
         XR    R15,R15
         IC    R15,TTRK+3
         CVD   R15,WORK1
         OI    WORK1+7,X'0F'
         UNPK  LINE1+L'ENDMSG0(2),WORK1+6(2)
         MVC   LINE1+L'ENDMSG0+2(ENDMSG1L),ENDMSG1
         L     R15,TOTALREC
         CVD   R15,WORK1
         ED    LINE1+L'ENDMSG0+L'ENDMSG1+2(L'ENDMSG1A),WORK1+4
         L     R15,COR2+4
         SRL   R15,10              CONVERT TO 'K'
         CVD   R15,WORK1
         OI    WORK1+7,X'F'
         UNPK  MSG7A,WORK1
         L     R1,COR7
         AL    R1,COR8
         SRL   R1,10
         SR    R15,R1
         CVD   R15,WORK1
         OI    WORK1+7,X'F'
         UNPK  MSG7B,WORK1
         MVC   LINE1+L'ENDMSG0+ENDMSG1L+4(MSG7L2-1),MSG7+1
ENDRUN11 EQU   *
         BAL   R10,PRNT            OUTPUT FINAL MSG
         LA    R8,SYSPUNCH         CLOSE ALL DCBS
         BAL   R10,TERMIO
         TM    SWB,SWB0            DEBUG?
         BO    ENDRUN31            YES, SKIP CLOSING SYSLIB
         LA    R8,SYSLIB
         CLOSE SYSLIB
ENDRUN31 EQU   *
         LA    R8,SYSLIST
         BAL   R10,TERMIO
         LA    R8,SYSPRINT
         BAL   R10,TERMIO
         TM    SWB,SWB0            DEBUG?
         BZ    ENDRUN99            NO
         LH    R2,RETCODE          YES, ABEND
         ABEND (R2),DUMP
ENDRUN99 EQU   *
         L     R13,4(R13)
         LH    R15,RETCODE
         RETURN (14,12),T,RC=(15)
         EJECT
*---------------------------------------------------------------------*
*        FORMAT AND PRINT THE 'SYSPRINT' LINE FOR A MEMBER
*---------------------------------------------------------------------*
         SPACE
         USING DIR,R4
LSTDIR   EQU   *
         ST    R10,SAVE10          SAVE CALLER'S RETURN
         MVC   LINE1+6(8),DIRNAME
         TM    DIRFLAGS,B'10000000' WAS THIS MEMBER PROCESSED?
         BZ    LSTDIR03            NO
         LH    R1,DIRPG1
         CVD   R1,WORK1
         MVC   WORK2(8),PAGEPAT
         ED    WORK2,WORK1+4
         MVC   LINE1+15(6),WORK2+2
LSTDIR03 EQU   *
         LA    R15,LINE1+L'CAPTIONS-12
         LA    R0,L'DIRTTR
         LA    R1,DIRTTR
         BAL   R10,HEXCON
         LH    R15,DIRUSERL
         LTR   R15,R15
         BNP   LSTDIR10
         TM    SWD,SWD7            RITS/CRBE/CRJE?
         BZ    LSTDIR05            NO.
         LA    R1,LINE1+L'CAPTIONS
         LA    R2,DIRUSER
         BAL   R10,RITSINFO
         B     LSTDIR10
         SPACE
LSTDIR05 EQU   *
         LA    R15,LINE1+L'CAPTIONS
         LA    R1,DIRUSER
         LH    R0,DIRUSERL
         CH    R0,=H'30'           ARE SPF STATISTICS PRESENT     .SPF.
         BNE   LSTSPFX             NO, BRANCH                     .SPF.
         TM    SWE,SWE1+SWE2       SPF IN THIS PDS                .SPF.
         BNO   LSTSPFX             NO, BRANCH                     .SPF.
         TM    DIRTTR+3,X'60'      TTR'S IN USER DATA             .SPF.
         BNZ   LSTSPFX             YES, THIS ISNT SPF DATA        .SPF.
         IC    R0,DIRUSER          GET V OF V.M                   .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  1(2,R15),WORK1+6(2)                                .SPF.
         MVI   3(R15),C'.'                                        .SPF.
         IC    R0,DIRUSER+1        GET M OF V.M                   .SPF.
         CVD   R0,WORK1                                           .SPF.
         OI    WORK1+7,X'0F'                                      .SPF.
         UNPK  4(2,R15),WORK1+6(2)                                .SPF.
*        UNPK  11(5,R15),DIRUSER+4(4) YYDDD CREATED               .SPF.
*        MVC   10(2,R15),11(R15)                                  .SPF.
*        MVI   12(R15),C'/'                                       .SPF.
         MVC   WORK1(4),DIRUSER+4  YYDDD CREATED                  .SPF.
         L     R0,WORK1            YYDDD CREATED                  .SPF.
         BAL   R14,JULIAN                                         .SPF.
         MVC   9(7,R15),WORK1+1                                   .SPF.
*        UNPK  21(5,R15),DIRUSER+8(4) YYDDD LAST MODIFIED         .SPF.
*        MVC   20(2,R15),21(R15)                                  .SPF.
*        MVI   22(R15),C'/'                                       .SPF.
         MVC   WORK1(4),DIRUSER+8  YYDDD LAST MODIFIED            .SPF.
         L     R0,WORK1            YYDDD LAST MODIFIED            .SPF.
         BAL   R14,JULIAN                                         .SPF.
         MVC   19(7,R15),WORK1+1                                  .SPF.
         MVO   WORK1(3),DIRUSER+12(2) HHMM   LAST MODIFIED        .SPF.
         OI    WORK1+2,X'0F'                                      .SPF.
         UNPK  28(4,R15),WORK1(3)                                 .SPF.
         MVC   27(2,R15),28(R15)                                  .SPF.
         MVI   29(R15),C':'                                       .SPF.
         LH    R0,DIRUSER+14       CURRENT SIZE                   .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         MVC   32(6,R15),=X'402020202120'                         .SPF.
         ED    32(6,R15),WORK1+5                                  .SPF.
         LH    R0,DIRUSER+16       INITIAL SIZE                   .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         MVC   38(6,R15),=X'402020202120'                         .SPF.
         ED    38(6,R15),WORK1+5                                  .SPF.
         LH    R0,DIRUSER+18       LINES MODIFIED                 .SPF.
         N     R0,=A(X'0000FFFF')                                 .SPF.
         CVD   R0,WORK1                                           .SPF.
         MVC   44(6,R15),=X'402020202120'                         .SPF.
         ED    44(6,R15),WORK1+5                                  .SPF.
         MVC   52(10,R15),DIRUSER+20   USER ID                    .SPF.
         B     LSTDIR10                                           .SPF.
         SPACE
JULIAN   EQU   *                                                  .SPF.
         STM   R15,R1,JULIANS                                     .SPF.
         XC    WORK2,WORK2                                        .SPF.
         ST    R0,WORK2+4                                         .SPF.
         CVB   R1,WORK2            CONVERT DATE TO BINARY         .SPF.
         XR    R0,R0                                              .SPF.
         D     R0,=F'1000'         TO SEP YEAR AND DAY            .SPF.
         ST    R1,WORK2            SAVE YEAR                      .SPF.
         L     R15,=A(MONTHS1)     FOR STD YEAR                   .SPF.
         TM    WORK2+3,X'03'       LEAP YEAR?                     .SPF.
         BNZ   *+8                 NO                             .SPF.
         L     R15,=A(MONTHS2)     FOR LEAP YEAR                  .SPF.
         XR    R1,R1                                              .SPF.
JULIANX  EQU   *                                                  .SPF.
         SH    R0,0(R15)                                          .SPF.
         BNP   JULIANY                                            .SPF.
         LA    R1,3(R1)                                           .SPF.
         LA    R15,2(R15)                                         .SPF.
         B     JULIANX                                            .SPF.
         SPACE 1                                                  .SPF.
JULIANY  EQU   *                                                  .SPF.
         AH    R0,0(R15)                                          .SPF.
         MH    R0,=H'10'                                          .SPF.
         CVD   R0,WORK2            FOR DAY OF MONTH               .SPF.
         AL    R1,=A(MONTHS3)      FOR MON IN CHARS               .SPF.
         MVC   WORK1(8),=X'4020204B4B4B2020'                      .SPF.
         MVC   WORK1+3(3),0(R1)                                   .SPF.
         MVC   JULIANS+4(1),WORK2+6 DAY OF MONTH DDYYDDDF         .SPF.
         ED    WORK1(8),JULIANS+4                                 .SPF.
         CLI   WORK1+1,C' '                                       .SPF.
         BNE   *+8                                                .SPF.
         MVI   WORK1+1,C'0'                                       .SPF.
         LM    R15,R1,JULIANS                                     .SPF.
         BR    R14                                                .SPF.
         SPACE 1                                                  .SPF.
LSTSPFX  EQU   *                                                  .SPF.
         CH    R0,=H'32'
         BNH   *+8
         LA    R0,32
         BAL   R10,HEXCON
LSTDIR10 EQU   *
         TM    SWA,SWA2            LISTDIR ONLY?
         BO    LSTDIR90            YES
         TM    DIRFLAGS,B'10000000' WAS THIS MEMBER PROCESSED?
         BZ    LSTDIR90            NO
         MVC   WORK1(4),DIRCRDCT
         L     R1,WORK1
         CVD   R1,WORK1
         MVC   LINE1+24(L'MSG2A),MSG2A
         ED    LINE1+24(L'MSG2A),WORK1+5
LSTDIR90 EQU   *
         BAL   R10,PRNT
         L     R10,SAVE10
         BR    R10
         SPACE
*---------------------------------------------------------------------*
*        UPON ENTRY, R1=A(BUFFER), R2=A(DIRECTORY ENTRY)
*---------------------------------------------------------------------*
         SPACE
RITSINFO EQU   *
         CLI   DIRUSERL+1,5        CHECK LENGTH OF USER FIELD
         BL    UNKNOWN             SHORT.
         MVC   0(L'PAT1,R1),PAT1
         ED    0(L'PAT1,R1),0(R2)
         MVC   10(L'PAT1,R1),PAT1
         ED    10(L'PAT1,R1),3(R2)
         XC    WORK1,WORK1
         MVC   WORK1+2(2),6(R2)
         L     R15,WORK1
         CVD   R15,WORK1
         MVC   WORK2,PAT2
         ED    WORK2,WORK1+4
         MVC   23(4,R1),WORK2+4
         TM    SWD,SWD4+SWD5       CRJE?
         BO    CRJEINFO            YES.
CRBEINFO EQU   *
         MVC   42(3,R1),=C'SEQ'
         TM    9(R2),X'40'         SEQ/NOSEQ?
         BO    *+10                SEQ.
         MVC   40(2,R1),=C'NO'
         MVC   52(4,R1),=C'SCAN'
         TM    9(R2),X'80'         SCAN/NOSCAN?
         BO    *+10
         MVC   50(2,R1),=C'NO'
         TM    8(R2),X'40'         FORTRAN FILE?
         BZ    *+12                NO.
         MVC   30(7,R1),=C'FORTRAN'
         BR    R10
         TM    8(R2),X'20'         OTHER FILE?
         BZ    *+12                NO.
         MVC   30(5,R1),=C'OTHER'
         BR    R10
         TM    8(R2),X'08'         FLIST FILE?
         BZ    *+12                NO.
         MVC   30(5,R1),=C'FLIST'
         BR    R10
         TM    SWD,SWD5            RITS?
         BZ    *+20                YES
         TM    8(R2),X'10'         OBJMOD FILE?
         BZ    *+12                NO.
         MVC   30(6,R1),=C'OBJMOD'
         BR    R10
         SPACE
UNKNOWN  EQU   *
         MVC   30(7,R1),=C'???????'
         BR    R10
         SPACE
CRJEINFO EQU   *
         CLI   DIRUSERL+1,11       CHECK USER LENGTH
         BL    CRBEINFO            SHORT...HANDLE AS CRBE
         LA    R1,30(R1)           POINT AT ATTR AREA OF LINE
         CRJE  8,B'00100000','DATA,',5,CRJE20
         CRJE  8,B'00010000','TEXT,',5,CRJE20
         CRJE  8,B'00001000','DSLIST,',7,CRJE20
         CRJE  8,B'00000100','CLIST,',6,CRJE20
         CRJE  8,B'01000001','FORTH,',6,CRJE20
         CRJE  8,B'01000000','FORTG,',6,CRJE20
         CRJE  8,B'00000001','FORTE,',6,CRJE20
         TM    8(R2),B'10000010'   PL1?
         BNZ   CRJE15              YES.
         MVC   0(7,R1),=C'???????' NO, UNKNOWN.
         BR    R10                 QUIT.
         SPACE
CRJE15   EQU   *
         MVC   0(7,R1),=C'PL1(  ,'
         XR    R15,R15
         IC    R15,13(R2)          PL1 SORMARGIN
         CVD   R15,WORK1
         OI    WORK1+7,X'0F'
         UNPK  4(2,R1),WORK1(8)
         IC    R15,14(R2)
         CVD   R15,WORK1
         OI    WORK1+7,X'0F'
         UNPK  7(2,R1),WORK1(8)
         LA    R1,10(R1)
         CRJE  8,B'10000000','C48),',5,CRJE20
         MVC   0(5,R1),=C'C60),'
         LA    R1,5(R1)
CRJE20   EQU   *
         CRJE  9,B'10000000','SEQ,',4,CRJE21
         MVC   0(6,R1),=C'NOSEQ,'
         LA    R1,6(R1)
CRJE21   EQU   *
         TM    8(R2),B'11000011'   PL1 OR FORT?
         BZ    CRJE22              NO...SKIP SCAN
         CRJE  9,B'01000000','SCAN,',5,CRJE22
         MVC   0(7,R1),=C'NOSCAN,'
         LA    R1,7(R1)
CRJE22   EQU   *
         MVC   0(4,R1),=C'BLK='
         LH    R15,20(R2)
         CVD   R15,WORK1
         OI    WORK1+7,X'0F'
         UNPK  4(4,R1),WORK1(8)
         MVC   8(3,R1),=C',K='
         MVC   11(3,R1),10(R2)
         BR    R10
         EJECT
*---------------------------------------------------------------------*
*        *** SUBROUTINES ****
*---------------------------------------------------------------------*
         SPACE
VARMVC1  MVC   0(0,R1),0(R2)       FOR PRINTED OUTPUT
VARMVC3  MVC   CARD(*-*),0(R2)     FOR PUNCHED OUTPUT
         SPACE
SAVERC   EQU   *
         CH    R1,RETCODE          COMPARE TO CURRENT VALUE
         BNHR  R14                 RETURN IF NOT HIGHER
         STH   R1,RETCODE          REPLACE WITH NEW VALUE
         BR    R14
         SPACE
TERMINAT EQU   *
         LA    R13,SAVEAREA        TERMINATE PROCESSING
         MVC   LINE0(L'LPDS03I),LPDS03I
         BAL   R14,PUTMSG
         LA    R1,16               SET RETURN CODE
         STH   R1,RETCODE
         OI    SWC,SWC3            SET TERMINATE MODE
         B     ENDRUN              GOTO WRAPUP ROUTINE
         SPACE
PUTMSG   EQU   *
         MVC   LINECNT1,LINEMAX    FORCE PAGE EJECT
PUTMSGXX EQU   *
         ST    R14,SAVE14          SETUP FOR MSG OUTPUT
         PUT   SYSPRINT,LINE0
         MVI   LINE0,C' '
         MVC   LINE0+1(L'LINE0-1),LINE0
         L     R14,SAVE14          AND FALL THRU TO CLEARBUF
         BR    R14
         SPACE
PUNCHIT  EQU   *
         PUT   SYSPUNCH,CARD
         MVI   CARD,C' '
         MVC   CARD+1(L'CARD-1),CARD
         BR    R10
         SPACE
*---------------------------------------------------------------------*
*        TERMINATE I/O:  CLOSE DCB AND FREE BUFFER POOL
*---------------------------------------------------------------------*
         SPACE
TERMIO   EQU   *
         TM    DCBOFLGS,OFLGS      DCB OPEN?
         BZR   R10                 NO
         CLOSE ((R8))              YES, CLOSE THE DCB
         FREEPOOL  (R8)            AND FREE THE BUFFER POOL
         BR    R10                 RETURN
         SPACE
*---------------------------------------------------------------------*
*        STANDARD FILES DCB EXIT ROUTINES
*---------------------------------------------------------------------*
         SPACE
DCBEXIT1 EQU   *
         LA    R5,3200             FOR SYSIN & SYSPUNCH
         B     DCBEXITZ
         SPACE
DCBEXITA EQU   *
         LA    R5,3509             FOR SYSPRINT
         B     DCBEXITZ
         SPACE
DCBEXITB EQU   *
         LH    R5,=Y(7260)         FOR SYSLIST
DCBEXITZ EQU   *
         LH    R4,DCBLRECL         GET LRECL
         CH    R4,DCBBLKSI         BLKSIZE SPECIFIED?
         BNH   DCBEXITY            YES.
         STH   R5,DCBBLKSI         NO, USE DEFAULT.
DCBEXITY EQU   *
         XR    R2,R2               FORCE MULT BLKSIZE
         LH    R3,DCBBLKSI
         DR    R2,R4
         MH    R3,DCBLRECL
         STH   R3,DCBBLKSI
         BR    R14
         SPACE
*---------------------------------------------------------------------*
*        PDS DATA READ DCB EXIT ROUTINE
*---------------------------------------------------------------------*
         SPACE
DCBEXIT2 EQU   *
         MVC   SAVBLKSI,DCBBLKSI   SAVE DCB PARMS
         MVC   SAVLRECL,DCBLRECL
         MVC   SAVRECFM,DCBRECFM
         MVC   SAVBUFNO,DCBBUFNO
         MVI   DCBBUFNO,0          BUFFERING HANDLED INTERNALLY
         CLI   SAVBUFNO,0          IS BUFNO SPECIFIED?
         BNER  R14                 YES.
         MVI   SAVBUFNO,2          NO, USE DEFAULT.
         BR    R14
         SPACE
*---------------------------------------------------------------------*
*        END-OF-FILE DETECTED ON SYSLIB
*---------------------------------------------------------------------*
         SPACE
PDSEOF   BR    R10                 BETTER BE SET TO GOOD ADDR
         SPACE
SYNERR1  EQU   *
         SYNADAF   ACSMETH=BPAM    PDS-DATA READ I/O ERROR
         STM   R14,R12,SYNADSAV    SAVE REGS
         LR    R2,R1               SAVE POINTER TO MESSAGE
         BAL   R10,PRNT            --OUTPUT CURRENT LINE
         MVC   LINE0(L'LPDS02I),LPDS02I
         MVC   LINE0+L'LPDS02I(78),50(R2)
         BAL   R14,PUTMSG          REDO LASTLINE.
         MVC   LINE0(L'LPDS02I),LPDS02I
         MVC   LINE0+L'LPDS02I(L'HEAD2MEM),HEAD2MEM
         MVC   LINE0+L'LPDS02I+L'HEAD2MEM(8),NAME
         BAL   R14,PUTMSG
         LA    R1,8                SET THE RETURN CODE
         BAL   R14,SAVERC
         LM    R14,R12,SYNADSAV    RESTORE REGS
         SYNADRLS
         TM    SWB,SWB4            EROPT=TERM/ACC?
         BZ    SYNERR2             FOR TERM.
         BR    R14                 FOR ACC.
         SPACE
SYNERR2  EQU   *
         LA    R13,SAVEAREA        TERMINATE PROCESSING
         MVC   LINE0(L'LPDS03I),LPDS03I
         BAL   R14,PUTMSG
         LA    R1,16               SET RETURN CODE
         STH   R1,RETCODE
         OI    SWC,SWC3            SET TERMINATE MODE
         B     ENDRUN              GOTO WRAPUP ROUTINE
         SPACE
*---------------------------------------------------------------------*
*        HEX-BINARY TO HEX-CHARACTER CONVERSION ROUTINE
*        UPON ENTRY, R0=LENGTH OF SOURCE, R1=A(SOURCE), R15=A(TARGET)
*---------------------------------------------------------------------*
         SPACE
HEXCON   EQU   *
         IC    R14,0(R1)           PROCESS FOUR LSB'S
         N     R14,=F'15'
         IC    R14,HEXTBL(R14)
         STC   R14,1(R15)
         IC    R14,0(R1)           PROCESS FOUR MSB'S
         SRL   R14,4
         IC    R14,HEXTBL(R14)
         STC   R14,0(R15)
         LA    R1,1(R1)
         LA    R15,2(R15)
         SH    R0,=H'1'            LOOP?
         BP    HEXCON              YES.
         BR    R10                 NO, RETURN.
         SPACE
*---------------------------------------------------------------------*
*        OUTPUT A LINE TO SYSPRINT
*---------------------------------------------------------------------*
         SPACE
PRNT     EQU   *
         LA    R15,LINE1
         BAL   R14,SETCC
         LH    R15,LINECNT1
         LA    R15,0(R15,R1)
         STH   R15,LINECNT1
         CH    R15,LINEMAX         AT LIMIT?
         BNH   PRNTC               NO.
PRNTA    EQU   *
         LA    R15,5
         STH   R15,LINECNT1
         MVC   HEAD1PAG,PAGEPAT
         LH    R15,PAGENUM1
         LA    R15,1(R15)
         STH   R15,PAGENUM1
         CVD   R15,WORK1
         ED    HEAD1PAG,WORK1+4
         MVC   LINE0(121),HEAD1
         BAL   R14,PUTMSGXX
         MVI   LINE0,C'0'
         TM    SWD,SWD3            INITIAL PAGE?
         BZ    PRNTB               YES, SKIP CAPTIONS.
         MVC   LINE0(L'CAPTIONS),CAPTIONS
         TM    SWD,SWD7            RITS/CRBE?
         BZ    *+14                NO.
         MVC   LINE0+L'CAPTIONS(L'RITSCAP),RITSCAP
         B     *+10
         MVC   LINE0+L'CAPTIONS(L'USERCAP),USERCAP
         TM    SWE,SWE1+SWE2       SPF STATS IN THIS PDS          .SPF.
         BNO   *+10                NO.                            .SPF.
         MVC   LINE0+L'CAPTIONS(L'SPFSCAP),SPFSCAP                .SPF.
PRNTB    EQU   *
         BAL   R14,PUTMSGXX
         MVI   LINE1,C'0'
PRNTC    EQU   *
         MVC   LINE0,LINE1
         BAL   R14,PUTMSGXX
         MVI   LINE1,C' '
         MVC   LINE1+1(L'LINE1-1),LINE1
         BR    R10
         SPACE
*---------------------------------------------------------------------*
*        'SYSLIST' OUTPUT S/R
*---------------------------------------------------------------------*
         SPACE
LOUT     EQU   *
         LA    R15,LINE2
         BAL   R14,SETCC
         TM    SWD,SWD6            TEST FORCE EJECT
         BO    LOUTC               YES.
         TM    SWA,SWA5            IS THIS 'EJECT' FORMAT
         BZ    LOUTA               NO
         AH    R1,LINECNT2         UPDATE LINECOUNT FOR EJECT FORMAT
         STH   R1,LINECNT2
         CH    R1,LINEMAX          AT BOTTOM OF PAGE?
         BNH   LOUTE               NO
         B     LOUTC               YES, DO PAGE EJECT AND HEADER-2
         SPACE
LOUTA    EQU   *
         LH    R15,LINECNT2
         LA    R15,0(R1,R15)
         CLC   =C'0MEMBER=',LINE2  TEST FOR SPECIAL CASE
         BNE   LOUTA1              NO.
         LA    R15,2(,R15)         YES, EXTRA PADDING.
LOUTA1   EQU   *
         CH    R15,LINEMAX         TEST FOR LIMIT
         BH    LOUTB               AT LIMIT
         AH    R1,LINECNT2         UPDATE LINECNT
         STH   R1,LINECNT2
         B     LOUTE               AND OUTPUT THE LINE.
         SPACE
LOUTB    EQU   *
         MVI   LINE0,C' '
         MVC   LINE0+1(L'LINE0-1),LINE0
         LH    R1,LINECNT2
LOUTB1   EQU   *
         CH    R1,LINEMAX
         BNL   LOUTB2              PADDING DONE, GO OUTPUT HEADER
         ST    R1,SAVELOUT
         L     R1,ALISTDCB
         PUT   (1),LINE0
         L     R1,SAVELOUT
         LA    R1,1(,R1)
         B     LOUTB1
         SPACE
LOUTB2   EQU   *
         MVI   HEAD2,C'0'
         L     R1,ALISTDCB
         PUT   (1),HEAD2
         MVI   HEAD2,C'1'
LOUTC    EQU   *
         NI    SWD,255-SWD6        RESET SWITCH
         LA    R15,3
         TM    SWA,SWA5            IS THIS NOEJECT FORMAT?
         BO    *+8                 NO, IT IS EJECT
         LA    R15,2(,R15)         +2 FOR BOTTOM IN NOEJECT FORMAT
         STH   R15,LINECNT2
         MVC   HEAD2NAM,NAME
         MVC   HEAD2PAG,PAGEPAT
         LH    R15,PAGENUM2        UPDATE THE PAGE NUMBER
         LA    R15,1(R15)
         STH   R15,PAGENUM2
         CVD   R15,WORK1
         ED    HEAD2PAG,WORK1+4
         L     R1,ALISTDCB
         PUT   (1),HEAD2           OUTPUT THE PAGE HEADER
         MVI   LINE2,C'-'
LOUTE    EQU   *
         L     R1,ALISTDCB
         PUT   (1),LINE2           OUTPUT THE FORMATTED LINT
         MVI   LINE2,C' '          THEN CLEAR THE USED LINE WORKAREA
         MVC   LINE2+1(L'LINE2-1),LINE2
         BR    R10
         SPACE
SETCC    EQU   *
         CC    4000,0(R15),1,SETCC9
         CC    0,0(R15),+,SETCC9
         CC    3,0(R15),-,SETCC9
         CC    2,0(R15),0,SETCC9
         LA    R1,1                FORCE 'DEFAULT'
         MVI   0(R15),C' '
SETCC9   EQU   *
         BR    R14
         SPACE
GETLOW   EQU   *
         L     R1,COR4
         AR    R0,R1
         C     R0,COR6
         BNL   GETBAD
         ST    R0,COR4
         B     MAXUSED
         SPACE
GETHI    EQU   *
         L     R1,COR6
         SR    R1,R0
         C     R1,COR4
         BNH   GETBAD
         ST    R1,COR6
         L     R15,COR5
         SR    R15,R1
         C     R15,COR8
         BNH   *+8
         ST    R15,COR8
         BR    R14
         SPACE
GETBASE  EQU   *
         L     R1,COR3
         AR    R0,R1
         C     R0,COR5
         BNL   GETBAD
         ST    R0,COR3
RESETLO  EQU   *
         MVC   COR4,COR3
MAXUSED  EQU   *
         L     R15,COR4
         SR    R15,R1
         C     R15,COR7
         BNH   *+8
         ST    R15,COR7
         BR    R14
         SPACE
RESETHI  EQU   *
         MVC   COR6,COR5
         BR    R14
         SPACE
GETBAD   EQU   *
         MVC   LINE0(L'LPDS10I),LPDS10I
         BAL   R14,PUTMSGXX
         B     TERMINAT
         EJECT
*---------------------------------------------------------------------*
*        *** STORAGE AREAS, CONSTANTS, ETC. ****
*---------------------------------------------------------------------*
         SPACE
SAVEAREA DC    9D'0'               STD OS SAVE AREA
WORK1    DC    1D'0'
WORK2    DC    1D'0'
SYNADSAV DC    8D'0'               TO SAVE REGS IN SYNAD EXIT
COR1     DC    A(10*1024,500*1024)  MIN/MAX SIZE FOR GETMAIN
COR2     DC    A(0,0)              RETURNED ADDR AND SIZE
COR3     DC    A(*-*)              BOTTOM OF AREA
COR4     DC    A(*-*)              START BOTTOM OF VARIABLE AREA
COR5     DC    A(*-*)              TOP OF AREA
COR6     DC    A(*-*)
COR7     DC    A(0)
COR8     DC    A(0)
TIOT     DC    A(0)                POINTER TO TIOT
BFRS     DC    2A(0)
SAVELOUT DC    F'0'
SAVE10   DC    A(0)                TO SAVE REGS 10
SAVE14   DC    A(0)                TO SAVE REG 14
BUFFER0  DC    A(0)                PDS BUFFER LENGTH
BUFFER1  DC    A(0)                PDS BUFFER #1 ADDRESS
BUFFER2  DC    A(0)                PDS BUFFER #2 ADDRESS
TTRK     DC    F'0'                FOR FIND/POINT.
ECB      DC    F'0'
IOB      DC    0F'0',X'42',X'000000',A(ECB)
CSW      DC    XL8'0'
ACP      DC    A(*-*),A(SYSLIB)
         DC    A(0),Y(0,0)
MBB      DC    XL3'0'
CCHHR    DC    XL5'0'
RECORDS  DC    F'0'                COUNT OF TOTAL RECORDS IN LIB
TOTALREC DC    F'0'                TOTAL NO. OF LRECL PROCESSED
ALCB     DC    A(*-*)
ALISTDCB DC    A(SYSLIST)
NAMETBL1 DC    A(0)                POINTER TO DIRECTORY TABLE
NAMETBL2 DC    A(0)                POINTER TO SELECTED NAMES
CURRENT1 DC    2A(0)               PNTRS TO NAMETBL1 CURRENT
CURRENT2 DC    2A(0)               PNTRS TO NAMETBL2 CURRENT
DSCB     CAMLST SEARCH,DSNAME,VOLSER,WORKAREA
         DC    0D'0'
WORKAREA DC    XL160'00'           OBTAIN'S WORKAREA
DSNAME   DC    CL44' '
VOLSER   DC    CL6' '
SWITCHES DC    XL5'00'             RUN SWITCHES AND FLAGS         .PRC.
         ORG   *-5                                                .PRC.
SWA      DS    X
SWB      DS    X
SWC      DS    X
SWD      DS    X
SWE      DS    X                                                  .PRC.
         ORG   ,
EXLST1   DC    0F'0',X'85',AL3(DCBEXIT1)     SYSIN & SYSPUNCH
EXLSTA   DC    0F'0',X'85',AL3(DCBEXITA)     SYSPRINT
EXLSTB   DC    0F'0',X'85',AL3(DCBEXITB)     SYSLIST
EXLST2   DC    0F'0',X'05',AL3(DCBEXIT2)     FOR PDS DCB
JFCBADRS DC    X'80',AL3(*-*)
SAVBLKSI DC    H'0'
SAVLRECL DC    H'0'
SAVRECFM DC    X'00'
SAVBUFNO DC    AL1(0)
RETCODE  DC    H'0'                RETURN CODE
PAGENUM1 DC    H'0'                CURRENT SYSPRINT PAGE NUMBER
PAGENUM2 DC    H'0'                CURRENT SYSLIST  PAGE NUMBER
LINECNT1 DC    H'0'                CURRENT SYSPRINT LINE NUMBER
LINECNT2 DC    H'0'                CURRENT SYSLIST  LINE NUMBER
LINEMAX  DC    H'0'                MAXIMUM LINE NUMBER
MAXDIR   DC    H'0'
MAXLIST  DC    H'0'
MEMCNT   DC    H'0'
         DC    0F'0'
NAME2    DC    CL8' '              ALIAS NAME
NAME     DC    CL8' '              MEMBER NAME
DDPRINT  DC    CL8'&DDPRINT'       SYSPRINT
DDLIST   DC    CL8'&DDLIST'        SYSLIST
DDPUNCH  DC    CL8'&DDPUNCH'       SYSPUNCH
DDLIB    DC    CL8'&DDLIB'         SYSLIB
DDIN     DC    CL8'&DDIN'          SYSIN
SWAX     DC    B'&A(1)&A(2)&A(3)&A(4)&A(5)&A(6)&A(7)&A(8)'
SWBX     DC    B'&B(1)&B(2)&B(3)&B(4)&B(5)&B(6)&B(7)&B(8)'
SWEX     DC    B'&E(1)&E(2)&E(3)&E(4)&E(5)&E(6)&E(7)&E(8)'        .PRC.
UPDTE1   DC    C'./ ADD NAME='
UPDTE2   DC    C'./ ADD SSI=00000000,NAME='
UPDTESUB DC    C'><'                                              .PRC.
PAT1     DC    X'4021204B202020'
PAT2     DC    X'4020202020202120'
JULIANS  DC    3F'0'
CARD     DC    CL80' '
LINE0    DC    CL133' '
LINE1    DC    CL133' '
LINE2    DC    CL133' '
         DC     0D'0'
         LTORG
MONTHS1  DC    Y(31,28,31,30,31,30,31,31,30,31,30,31)
MONTHS2  DC    Y(31,29,31,30,31,30,31,31,30,31,30,31)
MONTHS3  DC    C'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'
*        DC    C' **** &ID - LISTPDS &VERSION (&RELEASE) ****'   *.PRC.
*        DC    C' **** GSFC - LISTPDS 7.3 (27MAR78) ****'         .PRC.
HEAD1VER DC    C' ----------  LISTPDS  7.3A  ---------- '         .PRC.
HEXTBL   DC    CL16'0123456789ABCDEF'
HEAD1    DC    C' '                SYSPRINT HEADING
HEAD1DAT DC    CL8' '
HEAD1TIM DC    CL9' '
HEAD1C1  DC    CL7' '
HEAD1VOL DC    CL6' '
HEAD1C2  DC    CL6' '
HEAD1DSN DC    CL44' ',C'   '
         ORG   *-69                                               .PRC.
HEDD1DSN DC    CL(4+44+8+6+7)' -- '      DSN -- VOL=XXXXXX        .PRC.
HEAD1MEM DC    CL7' '  ... MEMBER= ON SYSLIST
HEAD1NAM DC    CL8' '  ... MEMBER NAME ON SYSLIST
         DC    CL10' ',C'PAGE'
HEAD1PAG DC    CL8' '
HEAD1R   DC    X'F14021204B4B4B20204021204B20204B2020'
HEAD1C1R DC    CL7' - VOL='
HEAD1C2R DC    CL6', DSN='
HEAD2    DC    C'1'                SYSLIST HEADING
HEAD2DAT DC    CL8' '
HEAD2TIM DC    CL9' ',C' - VOL='
HEAD2VOL DC    CL6' ',C', DSN='
HEAD2DSN DC    CL44' ',C'   '
HEAD2MEM DC    CL7'MEMBER='  ... MEMBER= ON SYSLIST
XEAD2NAM DC    CL8' '  ... MEMBER NAME ON SYSLIST
         ORG   *-84                                               .PRC.
         DC    CL4' -- '                                          .PRC.
HEAD2NAM DC    CL8' '  ... MEMBER NAME ON SYSLIST                 .PRC.
HEDD2DSN DC    CL72' -- '                                         .PRC.
         DC    CL10' ',C'PAGE'
HEAD2PAG DC    CL8' '
*AGEPAT  DC    X'4020202020202120'                               *.PRC.
PAGEPAT  DC    X'4020202020202020'                                .PRC.
CAPTIONS DC    C'-     NAME       PAGE   RECORDS    T T R C    '
RITSCAP  DC    C' CREATED  MODIFIED  ACCESSED  ATTRIBUTES'
USERCAP  DC    C'USER INFORMATION (HEX)'
SPFSCAP  DC        C'VER.MOD  CREATED   LAST MODIFIED  SIZE  INIT   MOD+
                   ID'                                            .SPF.
*                     01.00    YY/DDD    YY/DDD HH:MM  XXXX  XXXX  XXXX
*                USERID                                           .SPF.
LPDS01I  DC    C'0LPDS01I  DIRECTORY I/O ERROR - '
LPDS02I  DC    C' LPDS02I  PDS DATA READ ERROR - '
LPDS03I  DC    C'0LPDS03I  EXECUTION ABORTED.'
LPDS04I  DC    C'0LPDS04I  OPEN ERROR FOR '
LPDS05I  DC    C'0LPDS05I  WARNING--PARAMETER SPECIFICATION ERROR'
LPDS06I  DC        C'0LPDS06I  INVALID DCB SPECIFICATIONS FOR &DDLIB DD+
               .  '
LPDS06I0 DC    C' NOT SUPPORTED.'
LPDS06I1 DC    C'MACHINE CONTROL CHARACTERS'
LPDS06I2 DC    C'VARIABLE SPANNED RECORDS'
LPDS06I3 DC    C'TRACK OVERFLOW'
LPDS06IA DC    C'BLKSIZE INVALID.'
LPDS06IB DC    C'INVALID RECFM.'
LPDS07I  DC        C'0LPDS07I WARNING--RITS/CRBE/CRJE PROCESSING DELETED
               ,  LIBRARY DCB PARMS NOT COMPATABLE.'
LPDS08I  DC    C'0LPDS08I  ERROR--PDS DIRECTORY NOT STANDARD FORMAT.'
LPDS09I  DC    C'0LPDS09I  UNABLE TO OPEN ',CL8' '
         DC    C'.  OPTION DELETED.'
LPDS09IL EQU   *-LPDS09I
LPDS10I  DC    C'0LPDS10I  WORKAREA EXCCEEDED .. RAISE REGION'
LPDS11I  DC    C'0LPDS11I ONLY DSORG=PS OR DSORG=PO ARE VALID'
MSG1     DC    C'0*** END OF LIBRARY *** '
MSG1A    DC    X'402020202120'
MSG1AX   DC    C' MEMBERS PROCESSED WITH A TOTAL OF'
MSG1B    DC    X'4020202020202120',C' RECORDS'
MSG1L    EQU   *-MSG1
MSG2     DC    C'0*** END OF MEMBER *** '
MSG2A    DC    X'402020202120',C' RECORDS PROCESSED   '
MSG2L    EQU   *-MSG2
MSG3     DC    C'****  MEMBER NOT FOUND IN LIBRARY'
MSG4     DC    C'****  IS AN ALIAS FOR '
MSG5     DC    C'****  ABOVE MEMBER IS AN ALIAS FOR '
MSG6     DC    C'0SPECIFIED PARMS --'
MSG7     DC    C'0WORKAREA SIZE: '
MSG7A    DC    C'XXX',C'K'
MSG7L1   EQU   *-MSG7
         DC    C',  NEVER USED: '
MSG7B    DC    C'XXX',C'K'
MSG7L2   EQU   *-MSG7
MSG8     DC    C'-LIBRARIES:'
MSG9     DC    C'0*** END OF SEQUENTIAL DATASET *** '
MSG9A    DC    X'402020202120',C' RECORDS PROCESSED   '
MSG9L    EQU   *-MSG9
ENDMSG0  DC    C'0*** END OF RUN ***   '
ENDMSG1  DC    C' LIBRARIES PROCESSED WITH A TOTAL OF '
ENDMSG1A DC    X'4020202020202120',C' RECORDS.'
ENDMSG1L EQU   *-ENDMSG1
ENDMSG2  DC    C' *** OPTIONS IN EFFECT *** '
ENDMSG3  DC    C'SPECIFIED-MEMBERS'
         SPACE
*---------------------------------------------------------------------*
*        DCB'S FOR LISTPDS
*---------------------------------------------------------------------*
         SPACE
         PRINT NOGEN
SYSPRINT DCB   DSORG=PS,MACRF=(PM),DDNAME=&DDPRINT,                +++++
               RECFM=FBA,LRECL=121,EXLST=EXLSTA
SYSLIST  DCB   DSORG=PS,MACRF=(PM),DDNAME=&DDLIST,                 +++++
               RECFM=FBA,LRECL=121,EXLST=EXLSTB
SYSPUNCH DCB   DSORG=PS,MACRF=(PM),DDNAME=&DDPUNCH,                +++++
               RECFM=FB,LRECL=80,EXLST=EXLST1
SYSLIB   DCB   DSORG=PO,MACRF=(R),DDNAME=&DDLIB,EODAD=PDSEOF,      +++++
               SYNAD=SYNERR1,NCP=1,EXLST=EXLST2
SYSIN    DCB   DSORG=PS,MACRF=(R),DDNAME=&DDIN,EODAD=BLDSEL90,    ++++++
               RECFM=FB,LRECL=80,EXLST=EXLST1
         DCBD  DSORG=(PS,PO),DEVD=(DA)
         EJECT
LISTPDS  CSECT ,
         SPACE
*---------------------------------------------------------------------*
*         PARAMETER ANALYSIS
*---------------------------------------------------------------------*
         SPACE
         USING PA,R6
PA       L     R2,0(R4)
         LH    R1,0(R2)
         LA    R2,2(R2)            BEGINNING OF STRING
         LTR   R3,R1               ANY PARMS SEPECIFIED?
         BZ    PGMINITA            NO PARMS...CONTINUE INIT
         MVC   LINE1(L'MSG6),MSG6
         BAL   R10,PRNT
         LA    R1,LINE1+10
         LR    R15,R3
         CH    R15,=H'110'
         BL    *+8
         LA    R15,110
         BCTR  R15,0
         EX    R15,VARMVC1
         BAL   R10,PRNT
         LA    R3,0(R2,R3)         END OF STRING
PALOOP   CR    R2,R3               END OF PARMS?
         BNL   PGMINITA            YES, GOTO COMPLETE INIT
         CLI   0(R2),C','          NULL PARM?
         BE    PAEND               YES.
         CLC   =C'LINECNT=',0(R2)
         BE    PA15
         CLC   =C'EROPT=',0(R2)
         BE    PA22
         CLC   =C'MAXLIST=',0(R2)
         BE    PA10
         PACL  LISTDIR,7,OI,SWA,SWA2,NI,SWA,255-SWA0
         PACL  DEBUG,5,OI,SWB,SWB0
         PACL  NODEBUG,7,NI,SWB,255-SWB0
         PACL  LIST,4,OI,SWA,SWA0
         PACL  NOLIST,6,NI,SWA,255-SWA0
         PACL  DECK,4,OI,SWA,SWA1
         PACL  NODECK,6,NI,SWA,255-SWA1
         PACL  UPDTE,5,OI,SWA,SWA3
         PACL  NOUPDTE,7,NI,SWA,255-SWA3
         PACL  SSI,3,OI,SWA,SWA6
         PACL  NOSSI,5,NI,SWA,255-SWA6
         PACL  RITS,4,NI,SWD,255-SWD5,OI,SWD,SWD4
         PACL  CRBE,4,NI,SWD,255-SWD4,OI,SWD,SWD5
         PACL  CRJE,4,OI,SWD,SWD4+SWD5
         PACL  TRUNC,5,OI,SWA,SWA7
         PACL  NOTRUNC,7,NI,SWA,255-SWA7
         PACL  HEXOUT,6,OI,SWB,SWB1
         PACL  NOHEXOUT,8,NI,SWB,255-SWB1
         PACL  NUM,3,OI,SWB,SWB3
         PACL  NONUM,5,NI,SWB,255-SWB3
         PACL  EJECT,5,OI,SWA,SWA5
         PACL  NOEJECT,7,NI,SWA,255-SWA5
         PACL  SELECT,6,NI,SWD,255-SWD2
         PACL  EXCLUDE,7,OI,SWD,SWD2
         PACL  SEL,3,OI,SWE,SWE0                                  .SEL.
         PACL  NOSEL,5,NI,SWE,255-SWE0                            .SEL.
         PACL  SPF,3,OI,SWE,SWE1                                  .SPF.
         PACL  NOSPF,5,NI,SWE,255-SWE1                            .SPF.
         OI    SWC,SWC0              FLAG BAD KEYWORK
PABAD    CLI   0(R2),C','            FIND NEXT KEYWORK
         BE    PALOOP
         LA    R2,1(,R2)
         CR    R2,R3
         BL    PABAD
PAERROR  OI    SWC,SWC0            FLAG PARM ERROR
         B     PGMINITA            AND GOTO COMPLETE INIT.
PAEND    CLI   0(R2),C','          COMMA?
         BNE   PALOOP              NO, LOOP.
         LA    R2,1(R2)            YES, BUMP OVER IT.
         B     PALOOP
PA10     LA    R2,8(,R2)
         XR    R15,R15
         CR    R2,R3
         BNL   PAERROR
PA10A    CR    R2,R3
         BNL   PA10B
         CLI   0(R2),C','
         BE    PA10B
         CLI   0(R2),C'0'
         BL    PAERROR
         CLI   0(R2),C'9'
         BH    PAERROR
         MH    R15,=H'10'
         IC    R1,0(R2)            PICK UP CHAR
         N     R1,=F'15'           AND MASK OFF HIGH BITS
         LA    R15,0(R1,R15)
         LA    R2,1(R2)
         B     PA10A
PA10B    N     R15,=F'32767'
         STH   R15,MAXLIST
         OI    SWA,SWA4            FLAG MAXLIST= SPECIFIED.
         B     PAEND
PA15     LA    R2,8(R2)            LINECNT
         XR    R15,R15
         CR    R2,R3
         BNL   PAERROR
PA15A    CR    R2,R3
         BNL   PA15B
         CLI   0(R2),C','
         BE    PA15B
         CLI   0(R2),C'0'
         BL    PAERROR
         CLI   0(R2),C'9'
         BH    PAERROR
         MH    R15,=H'10'
         IC    R1,0(R2)            PICK UP CHAR
         N     R1,=F'15'           AND MASK OFF HIGH BITS
         LA    R15,0(R1,R15)
         LA    R2,1(R2)
         B     PA15A
PA15B    N     R15,=F'32767'
         BCTR  R15,0                                              .LCT.
         STH   R15,LINEMAX
         B     PAEND
PA22     LA    R2,6(R2)            EROPT=
         PACL  TERM,4,NI,SWB,255-SWB3
         PACL  ACC,3,OI,SWB,SWB4
         B     PAERROR
         SPACE
*---------------------------------------------------------------------*
*        LIST THE RUN OPTIONS
*---------------------------------------------------------------------*
         SPACE
         USING PRMLST,R6
PRMLST   TM    SWC,SWC0            PARM ERROR?
         BZ    PRMLST0         ... NO
         MVC   LINE1(L'LPDS05I),LPDS05I
         BAL   R10,PRNT
         LA    R1,4
         BAL   R14,SAVERC
PRMLST0  MVI   LINE1,C'-'
         BAL   R10,PRMLSTXZ
         P1    SWB,SWB0,DEBUG,5
         P1    SWA,SWA2,LISTDIR,7
         TM    SWD,SWD4+SWD5          RITS/CRBE/CRJE
         BZ    PRMLST20               NO
         BO    PRMLST19               YES, CRJE
         P1    SWD,SWD4,RITS,4
         P1    SWD,SWD5,CRBE,4
         B     PRMLST20
PRMLST19 P1    SWD,SWD4+SWD5,CRJE,4
PRMLST20 TM    SWA,SWA2               LISTDIR?
         BO    PRMLST50            YES
         P2    SWA,SWA0,LIST,4
         P2    SWB,SWB3,NUM,3
         P2    SWA,SWA5,EJECT,5
         P2    SWA,SWA7,TRUNC,5
         P2    SWB,SWB1,HEXOUT,6
         P2    SWA,SWA1,DECK,4
         P2    SWA,SWA3,UPDTE,5
         P2    SWA,SWA6,SSI,3
         P2    SWE,SWE1,SPF,3                                    JDM1
PRMLST50 MVC   0(8,R2),=C'LINECNT='
         LH    R1,LINEMAX
         LA    R1,1(,R1)                                          .LCT.
         CVD   R1,WORK1
         OI    WORK1+7,X'F'
         UNPK  8(3,R2),WORK1
         CH    R1,=H'999'
         BNH   *+14
         UNPK  8(5,R2),WORK1
         LA    R2,2(,R2)
         LA    R2,11(,R2)
         BAL   R10,PRMLSTXX
         TM    SWA,SWA4
         BZ    PRMLST55
         MVC   0(8,R2),=C'MAXLIST='
         LH    R1,MAXLIST
         CVD   R1,WORK1
         OI    WORK1+7,X'F'
         UNPK  8(3,R2),WORK1
         CH    R1,=H'999'
         BNH   *+14
         UNPK  8(5,R2),WORK1
         LA    R2,2(,R2)
         LA    R2,11(,R2)
         BAL   R10,PRMLSTXX
PRMLST55 MVC   0(6,R2),=C'EROPT='
         MVC   6(3,R2),=C'ACC'
         TM    SWB,SWB4
         BZ    *+14
         MVC   6(4,R2),=C'TERM'
         LA    R2,1(,R2)
         LA    R2,9(,R2)
         TM    SWD,SWD0            SELECTED MEMBERS?
         BZ    PRMLST60
         BAL   R10,PRMLSTXX
         P1    SWD,SWD2,SELECT,6,BR=BO
         P1    SWD,SWD2,EXCLUDE,7
         MVC   0(L'ENDMSG3,R2),ENDMSG3
         LA    R2,L'ENDMSG3(,R2)
PRMLST60 BAL   R10,PRNT
         SPACE
*---------------------------------------------------------------------*
*        LIST THE LCB INFO
*---------------------------------------------------------------------*
         SPACE
         MVC   LINE1(L'MSG8),MSG8
         BAL   R10,PRNT
         MVI   LINE1,C'0'
         XR    R3,R3         INIT LIB COUNT
         L     R2,ALCB
         USING LCB,R2
LCBLST00 CLI   LCB,X'FF'
         BE    LCBLST90
         LA    R3,1(,R3)   INCR LIB COUNT
         CVD   R3,WORK1
         OI    WORK1+7,X'F'
         UNPK  LINE1+5(2),WORK1
         MVI   LINE1+8,C'-'
*        MVC   LINE1+10(4),=C'VOL='                              *.PRC.
*        MVC   LINE1+14(6),LCBVOLNO                              *.PRC.
*        MVC   LINE1+22(4),=C'DSN='                              *.PRC.
*        MVC   LINE1+26(44),LCBDSNAM                             *.PRC.
         MVC   LINE1+10(44),LCBDSNAM                              .PRC.
         MVC   LINE1+58(6),LCBVOLNO                               .PRC.
         MVC   LINE1+72(8),=C'DSORG=??'
         TM    LCBDS1DS,B'10000000'
         BZ    *+10
         MVC   LINE1+78(2),=C'IS'
         TM    LCBDS1DS,B'01000000'
         BZ    *+10
         MVC   LINE1+78(2),=C'PS'
         TM    LCBDS1DS,B'00100000'
         BZ    *+10
         MVC   LINE1+78(2),=C'DA'
         TM    LCBDS1DS,B'00000010'
         BZ    *+10
         MVC   LINE1+78(2),=C'PO'
         MVC   LINE1+82(7),=C'RECFM=?'
         TM    LCBDS1RF,B'11000000'  FILL IN THE RECFM
         BO    LCBLST32
         BZ    LCBLST33
         TM    LCBDS1RF,B'01000000'   V?
         BO    LCBLST31               YES
         MVI   LINE1+88,C'F'
         B     LCBLST33
LCBLST31 MVI   LINE1+88,C'V'
         B     LCBLST33
LCBLST32 MVI   LINE1+88,C'U'
LCBLST33 TM    LCBDS1RF,B'00010000'
         BZ    *+8
         MVI   LINE1+89,C'B'
         TM    LCBDS1RF,B'00001000'
         BZ    *+8
         MVI   LINE1+90,C'S'
         TM    LCBDS1RF,B'00100000'
         BZ    *+8
         MVI   LINE1+90,C'T'
         TM    LCBDS1RF,B'00000100'
         BZ    *+8
         MVI   LINE1+91,C'A'
         TM    LCBDS1RF,B'00000010'
         BZ    *+8
         MVI   LINE1+91,C'M'
LCBLST50 MVC   LINE1+94(6),=C'LRECL='
         LH    R1,LCBDS1LR
         CVD   R1,WORK1
*        OI    WORK1+7,X'F'                                      *.PRC.
*        UNPK  LINE1+100(5),WORK1                                *.PRC.
         LA    R1,LINE1+100                                       .PRC.
         MVC   0(7,R1),=X'40202020212040'                         .PRC.
         ED    0(6,R1),WORK1+5                                    .PRC.
         CLI   0(R1),C' '          LOOK FOR FIRST NONBLANK        .PRC.
         BNE   *+14                BRANCH IF NONBLANK FOUND       .PRC.
         MVC   0(6,R1),1(R1)       SHIFT LEFT                     .PRC.
         B     *-14                BACK TO CLI                    .PRC.
         MVC   LINE1+107(8),=C'BLKSIZE='
         LH    R1,LCBDS1BL
         CVD   R1,WORK1
*        OI    WORK1+7,X'F'                                      *.PRC.
*        UNPK  LINE1+115(5),WORK1                                *.PRC.
         LA    R1,LINE1+115                                       .PRC.
         MVC   0(7,R1),=X'40202020212040'                         .PRC.
         ED    0(6,R1),WORK1+5                                    .PRC.
         CLI   0(R1),C' '          LOOK FOR FIRST NONBLANK        .PRC.
         BNE   *+14                BRANCH IF NONBLANK FOUND       .PRC.
         MVC   0(6,R1),1(R1)       SHIFT LEFT                     .PRC.
         B     *-14                BACK TO CLI                    .PRC.
         BAL   R10,PRNT
         LA    R2,LCBEND
         B     LCBLST00
         DROP  R2
LCBLST90 EQU   *
*
         OI    SWD,SWD3            TURN OFF FIRST TIME SW
         MVC   HEAD1C1,HEAD1C1R
         MVC   HEAD1C2,HEAD1C2R
         B     BEGIN
         SPACE
*---------------------------------------------------------------------*
*        *** INITIALIZATION COMPLETE ****
*---------------------------------------------------------------------*
         SPACE
PRMLSTXX CR    R2,R3
         BNL   PRMLSTXY
         MVI   0(R2),C','
         LA    R2,1(,R2)
         BR    R10
PRMLSTXY ST    R10,SAVE10
         BAL   R10,PRNT
         L     R10,SAVE10
PRMLSTXZ MVC   LINE1+3(L'ENDMSG2),ENDMSG2
         LA    R2,L'ENDMSG2+LINE1+4
         LA    R3,LINE1+70
         BR    R10
*
         DC    0D'0'
         LTORG
         EJECT
*---------------------------------------------------------------------*
*        DEFINE THE DSECT'S HERE
*---------------------------------------------------------------------*
         SPACE
LCB      DSECT ,
LCBDSNAM DC    CL44' '             LIBRARY'S DATASET NAME
LCBVOLNO DC    CL6' '              LIBRARY'S VOLUME SERIAL
LCBJFCDS DC    X'00'               JFCB DSORG
LCBJFCRF DC    X'00'               JFCB RECFM
LCBJFCLR DC    H'0'                JFCB LRECL
LCBJFCBL DC    H'0'                JFCB BLKSIZE
LCBDS1DS DC    X'00'               DSCB DSORG
LCBDS1RF DC    X'00'               DSCB RECFM
LCBDS1LR DC    H'0'                DSCB LRECL
LCBDS1BL DC    H'0'                DSCB BLKSIZE
LCBDIR   DC    H'0'                MAX DIR-BLKSIZE/TRK ON THIS VOL
LCBEND   DC    0F'0'
LCBLEN   EQU   LCBEND-LCB
         SPACE
*---------------------------------------------------------------------*
         SPACE
DIR      DSECT
DIRCRDCT DC    XL4'0'              RECORD COUNT
DIRPG1   DC    H'0'                PAGE NUMBER
DIRFLAGS DC    B'00000000'         FLAGS
         DC    X'00'               NOT USED
DIRUSERL DC    H'0'                LENGTH OF USER DATA
DIRNAME  DC    CL8' '              MEMBER NAME
DIRTTR   DC    XL4'0'
DIRUSER  EQU   *
DIREND   EQU   *
DIRLEN   EQU   *-DIR    ... PLUS LEN OF 'USER DATA'
         SPACE
*---------------------------------------------------------------------*
         SPACE
NAMTBL   DSECT
NAMTBL1  DC    CL8' '
NAMTBL2  DC    A(*-*)
NAMTBL3  DC    F'0'
NAMTBL4  DC    H'0'
NAMTBL5  DC    H'0'
NAMTBLXX EQU   *-NAMTBL
         SPACE
         DC    0D'0'
         END   LISTPDS
//LKED.SYSLMOD DD DSN=SYS2.LINKLIB,DISP=SHR                             00100000
//LKED.SYSIN DD *                                                       00110000
 NAME LISTPDS(R)                                                        00120000
//                                                                      00130000
