//VTOCLIST  JOB (TSO),
//             'Install VTOCLIST',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//********************************************************************  00020000
//* INSTALL VTOCLIST (CBT FILE #343)                                    00030000
//********************************************************************  00040000
//VTOCLIST EXEC ASMFCL,MAC1='SYS1.AMODGEN'                              00050000
//ASM.SYSIN DD *                                                        00060000
         MACRO                                                          00010000
         REGEQU                                                         00020000
R0       EQU   0                                                        00030000
R1       EQU   1                                                        00040000
R2       EQU   2                                                        00050000
R3       EQU   3                                                        00060000
R4       EQU   4                                                        00070000
R5       EQU   5                                                        00080000
R6       EQU   6                                                        00090000
R7       EQU   7                                                        00100000
R8       EQU   8                                                        00110000
R9       EQU   9                                                        00120000
R10      EQU   10                                                       00130000
R11      EQU   11                                                       00140000
R12      EQU   12                                                       00150000
R13      EQU   13                                                       00160000
R14      EQU   14                                                       00170000
R15      EQU   15                                                       00180000
         MEND                                                           00190000
         TITLE 'VTOCLIST - LIST VTOC OF SYSUT1'
***********************************************************************
**@@NAME=U10001AS      EUROPEAN GUIDE MODS SEE ABSTR.FLE. 3-75 GUIDE  *
*                                                                     *
* AUTHOR -     P.E.HAVERCAN - C.A.V. LIMITED                          *
*                                                                     *
* TITLE -      VTOCLIST                                               *
*                                                                     *
* FUNCTION -   LIST THE VTOC ON A DASD VOLUME                         *
*                                                                     *
* JCL -        //VTOCLIST   EXEC  PGM=VTOCLIST                        *
*              //SYSPRINT   DD  SYSOUT=*                              *
*              //SYSUT1     DD  UNIT=SYSALLDA,DISP=SHR,VOL=SER=VVVVVV *
*                                                                     *
*              PARM='PDS' WILL PRINT DIRECTORY BLOCKS ALLOCATED/USED  *
*              INSTEAD OF THE CREATION/LAST REFERENCE DATES.  THIS    *
*              REQUIRES READALL IN ACF2 (RACF?) IN ORDER TO OPEN EACH *
*              PDS DIRECTORY ON THE VOLUME WITHOUT GETTING SECURITY   *
*              VIOLATIONS.                                            *
*                                                                     *
* ATTRIBUTES - NONREUSABLE                                            *
*                                                                     *
* MODIFIED   - JOHN KALINICH, USA LOGISTICS SYSTEMS SUPPORT CENTER    *
*                                                                     *
* 09/20/78 -   FIX MISCELLANEOUS BUGS AND 0C4 ABENDS.                 *
*                                                                     *
*              PDS DIRECTORY BLOCKS ALLOCATED/USED OPTION.            *
*                                                                     *
* 09/18/85 -   PRINT THE LAST REFERENCE DATE INSTEAD OF THE           *
*              EXPIRATION DATE.                                       *
*                                                                     *
*              3380/3390 SUPPORT.                                     *
*                                                                     *
*              PRINT DATES IN AMERICAN (MM/DD/YY) FORMAT              *
*              INSTEAD OF EUROPEAN (DD/MM/YY) FORMAT.                 *
*                                                                     *
* 06/10/88 -   PRINT UP TO 123 EXTENTS FOR ICF VSAM DATA SETS.        *
*                                                                     *
* 01/09/98 -   PROCESS YEAR 2000 VTOC DATES CORRECTLY.                *
*                                                                     *
* 08/12/99 -   DISPLAY NEW DSORG TYPES:  PDSE, HFS, AND VSAM EF       *
*                                                                     *
***********************************************************************
         MACRO
&NAME    #SORT &FIELDS=(1,1,CH,A),&FIRST=,&LAST=,&A=,&FORMAT=,         *
               &LENGTH=
.*       AUTHOR - PETER HAVERCAN
         GBLC  &##EQU
         LCLA  &X,&Y,&Z,&LEN
         LCLC  &HI,&LO,&R0,&R1,&R14,&R15
&X       SETA  N'&FIELDS
         AIF   (&X NE 3 AND &X NE 4).ERR1
         AIF   (&X EQ 4 AND '&FIELDS(3)' NE 'CH').ERR2
&HI      SETC  'H'
&LO      SETC  'L'
         AIF   ('&FIELDS(&X)' NE 'D').TESTA
&HI      SETC  'L'
&LO      SETC  'H'
         AGO   .SETREGS
.TESTA   AIF   ('&FIELDS(&X)' EQ 'A').SETREGS
         MNOTE *,'*** SORT TYPE NOT A OR D - A ASSUMED'
.SETREGS ANOP
&R0      SETC  '&##EQU.0'
&R1      SETC  '&##EQU.1'
&R14     SETC  '&##EQU.14'
&R15     SETC  '&##EQU.15'
         AIF   ('&LENGTH' EQ '').NOLNGTH
&LEN     SETA  &LENGTH
         AGO   .LENSET
.NOLNGTH ANOP
&LEN     SETA  L'&FIRST
.LENSET  ANOP
&X       SETA  &FIELDS(1)-1            OFFSET WITHIN RECORD
&Y       SETA  &FIELDS(2)              LENGTH OF SORT-KEY
&Z       SETA  &X+&LEN                 OFFSET WITHIN NEXT RECORD
         AIF   ('&FIRST&LAST' EQ '').ATYPE
&NAME    LA    &R15,&FIRST             ADDRESS FIRST ENTRY
         LA    &R0,&LENGTH             LOAD WIDTH OF TABLE
         LA    &R1,&LAST               ADDRESS LAST ENTRY
         AGO   .STEPBCK
.ATYPE   AIF   ('&A' EQ '').ERR3
&NAME    LM    &R15,&R1,&A             FIRST ENTRY,WIDTH,LAST ENTRY
.STEPBCK ANOP
         SR    &R1,&R0                 R1 POINTS AT PENULTIMATE
         CLC   &X.(&Y,&R15),&Z.(&R1)   COMPARE FIRST & LAST ENTRIES
         B&LO  *+22                    RECDS IN SEQUENCE
         XC    0(&LEN,&R15),&LEN.(&R1) SWITCH FIRST AND
         XC    &LEN.(&LEN,&R1),0(&R15) LAST ENTRIES INTO
         XC    0(&LEN,&R15),&LEN.(&R1) CORRECT SEQUENCE
         LA    &R14,&LEN.(&R15)        ADDRESS NEXT RECORD
         CLC   &X.(&Y,&R14),&X.(&R15)  COMPARE SORT KEYS
         BN&LO *+26                    IN SEQUENCE FROM FRONT
         XC    0(&LEN,&R14),0(&R15)    SWITCH FIELDS
         XC    0(&LEN,&R15),0(&R14)    WHICH ARE OUT
         XC    0(&LEN,&R14),0(&R15)    OF SEQUENCE
         B     *+32                    GO TO LOOP CONTROL
         CLC   &X.(&Y,&R14),&Z.(&R1)   COMPARE WITH FINAL RECORD
         BN&HI *+22                    IN SEQUENCE FROM REAR
         XC    0(&LEN,&R14),&LEN.(&R1) SWITCH FIELDS
         XC    &LEN.(&LEN,&R1),0(&R14) WHICH ARE OUT
         XC    0(&LEN,&R14),&LEN.(&R1) OF SEQUENCE
         BXLE  &R14,&R0,*-60           INCREMENT & LOOP BACK
         SR    &R1,&R0                 DECREMENT END POINTER
         BXLE  &R15,&R0,*-98           ADVANCE FRONT POINTER
         MEXIT
.ERR1    MNOTE 8,'INVALID NO. OF ENTRIES IN FIELDS PARAMETER'
         MEXIT
.ERR2    MNOTE 4,'FORMAT TYPE IS NOT SUPPORTED'
         MEXIT
.ERR3    MNOTE 8,'NEITHER A NOR FIRST AND LAST ARE SPECIFIED'
         MEND
*
         MACRO
&NAME    ERROR &A
&NAME    ABEND &A
         MEND
*
         EJECT
VTOCLIST CSECT
*        AUTHOR - P.E.HAVERCAN - C.A.V. LIMITED
         REGEQU                        * SYMBOLIC REGISTERS
         USING VTOCLIST,R15            * ADDRESS SAVEAREA
         STM   R14,R12,12(R13)         * SAVE REGISTERS
         ST    R13,SAVEAREA+4          * BACKWARD TO CALLER
         LR    R5,R13                  * KEEP FOR A WHILE
         CNOP  0,4                     * ALIGN TO FULLWORD FOR R13
         BAL   R13,SAVEAREA+72         * PRIME 1ST BASE
         DROP  R15
         USING *,R13,R12               * DECLARE BASE REGISTERS
SAVEAREA DC    18F'0'                  * 72-BYTE SAVEAREA
         ST    R13,8(R5)               * FORWARD FROM CALLER
         LA    R12,2048(R13)           * +2K PAST 1ST BASE
         LA    R12,2048(R12)           * +4K PAST 1ST BASE
         LM    R10,R11,0(R1)           * PICK UP PARM ADDR & DCB ADDR
         CLC   0(2,R10),=XL2'0000'     * PARM ENTERED?
         BE    NOPARM                  * NO
         MVC   PARM(3),2(R10)          * YES, KEEP
NOPARM   EQU   *
         LTR   R10,R10                 * ONLY PARM SUPPLIED?
         BNM   SKIPOPEN                * NO, OMIT INITIALIZATION OF DCB
         RDJFCB MF=(E,OPENVTOC)        * READ VTOC JFCB
         MVI   JFCBDSNM,X'04'          * SET UP
         MVC   JFCBDSNM+1(43),JFCBDSNM * VTOC DSNAME
         OI    JFCBAREA+52,X'08'       * INDICATE NO JFCB WRITE-BACK
         OPEN  MF=(E,OPENVTOC),TYPE=J  * OPEN VTOC
         LA    R11,VTOC                * ADDRESS THE OPENED DCB
SKIPOPEN ST    R11,VTOCDECB+8          * AND SAVE IN DECB
         TM    48(R11),X'10'           * CHECK DCB IS OPEN
         BO    GOODOPEN                * LOOKS OK
ERR1     EQU   *
         ERROR 1
GOODOPEN TM    48(R11),X'02'           * DO I HAVE THE DCB TO MYSELF?
         BO    NOUSER                  * I THINK SO
         ERROR 2                       * MAYBE NOT
NOUSER   EQU   *
         OPEN  (PRINTER,OUTPUT)        * OPEN PRINT FILE
         TM    PRINTER+48,X'10'        * TEST THAT OPEN WORKED
         BZ    ERR1                    * ERROR OPENING PRINTER
* SET UP HDR1 LINE FOR HEAD OF PAGE
         MVC   HDR1VOL,JFCBVOLS        * VOLUME SERIAL NO
         TIME  DEC                     * GET TIME OF JOB
         ST    R0,DWORK+4              * SAVE TIME IN WORKAREA
         ED    HDR1TIME,DWORK+4        * MOVE TO OUTPUT
         SR    R0,R0                   * CLEAR OUT R0
         STM   R0,R1,DWORK             * SAVE DECIMAL DATE
         CVB   R1,DWORK                * CONVERT DEC DATE TO BIN
         D     R0,=F'1000'             * SPLIT INTO YEAR & DAY
         ST    R0,DWORK+4              * STORE BINARY DAYS
         STH   R1,DWORK+4              * STORE BINARY YEAR
         BAL   R9,DATECONV             * GO CONVERT DATE
         ED    HDR1DATE,DWORK+4        * THEN USE CNVRTED RESULT
         EJECT
* SETUP TO READ FORMAT 4 DSCB
         L     R3,44(R11)              * PICK UP DEB ADDR FROM DCB
         MVC   VTOCFDAD+1(6),36(R3)    * MOVE BBCCHH OF EXTENT START
         MVI   VTOCFDAD+7,1            * POINT TO 1ST RECD = FMT4
         BAL   R9,READDSCB+6           * READ THE FORMAT 4
         CLI   DS1FMTID,C'4'           * IS IT REALLY A FORMAT 4 ?
         BE    MOVEFMT4                * FORTUNATELY, YES
         ERROR 3                       * HOW DID WE GET HERE?
MOVEFMT4 MVC   DS4DATA(71),DS1FMTID    * MOVE FORMAT4 DATA TO SPEC AREA
         BAL   R9,POINTF5              * GO DO THE CALCULATION PROPERLY
         LH    R4,46(R3)               * PICK # TRKS IN VTOC FROM DEB
         SR    R5,R5                   * CLEAR R5
         IC    R5,DS4DEVDT             * INSERT NO OF DSCB'S PER TRK
         MR    R4,R4                   * WHENCE FIND # OF DSCBS IN VTOC
         M     R4,TBLWIDTH             * MULT BY AMT OF CORE PER ENTRY
GETMAIN  GETMAIN EC,LV=(5),A=TABLADDR  * ESTIMATE CORE REQ FOR FORMAT1S
         B     *+4(R15)                * SEE IF CORE WAS AVAILABLE
         B     GOTCORE                 * YES, GO BUILD TABLE
* INSUFFICIENT CORE TO SORT FORMAT1 DSCBS - POINT ROUTINE TO PICK UP
* THE SORTED ENTRIES TO THE ROUTINE WHICH READS THEM THE FIRST TIME
         LA    R2,READFMT1             * GET ROUTINE ADDR
         ST    R2,RTNADDR              * SAVE IT
         LA    R2,ENDUP                * GET END-OF-FILE ROUTINE
         ST    R2,EODADDR              * SAVE IT
         B     PRNTDSCB                * AND GO IMMEDIATELY TO PRINT
         EJECT
GOTCORE  EQU   *
         L     R4,TABLADDR             * R4 -> TABLE OF DSCBS
BLDLOOP  BAL   R9,READFMT1             * READ A FORMAT1 DSCB
         MVC   0(1,R4),DS1DSORG        * DSORG IS HI-ORDER SORT-KEY
         NI    0(R4),B'10000000'       * TO DISTINGUISH ISAM FILES
         MVC   1(44,R4),DS1DSNAM       * MOVE DSNAME INTO TABLE
         MVC   45(5,R4),VTOCFDAD+3     * SET RECORD ADDR OF THIS DSCB
         LA    R4,50(R4)               * BUMP TABLE POINTER
         B     BLDLOOP                 * AND GO READ NEXT FORMAT 1
VTOCEOD  EQU   *                       * COME HERE WHEN DSCBS EXHAUSTED
         S     R4,TBLWIDTH             * POINT TO LAST TABLE ENTRY
         ST    R4,TABLEND              * SAVE IN #SORT LIST
         CP    FMT1CNT,=P'1'           * HOW MANY DATA SETS ON VOLUME
         BE    VTOCEOD1                * ONLY 1, BYPASS THE SORT
         BL    PRNTDSCB                * NO FORMAT 1 DSCBS READ
         #SORT FIELDS=(1,45,CH,A),A=TABLADDR,LENGTH=50 SORT TABLE
VTOCEOD1 EQU   *
         L     R4,TABLADDR             * RESET R4 -> TABLE OF DSCBS
         S     R4,TBLWIDTH             * THEN POINT TO PREVIOUS AREA
         EJECT
PRNTDSCB PUT   PRINTER                 * GET A PRINT BUFFER
         USING HDRLINE,R1              * MAP OUTPUT LINE
         MVI   0(R1),C' '              * SINGLE SPACE NORMALLY
         SP    LINECNTR,=P'1'          * DECREMENT LINE-COUNTER
         BP    PRINTBR                 * NOT HEAD OF PAGE
         MVC   0(133,R1),HDR1          * MOVE IN A PAGE HEADER
         AP    PAGECNTR,=P'1'          * ADD 1 TO PAGE-COUNTER
         ED    HDPAGCNT,PAGECNTR       * AND MOVE TO HEADER LINE
         PUT   PRINTER                 * GET A PRINT BUFFER
         CLC   PARM(3),=CL3'PDS'       * DIR BLKS ALLOC/USED REQUEST
         BNE   NOTPO1                  * NO, LEAVE HEADERS ALONE
         MVC   HDR2(133),HDR2P         * DIRECTORY BLOCKS
         MVC   HDR3(133),HDR3P         * ALLOC     USED
NOTPO1   EQU   *
         MVC   0(133,R1),HDR2          * MOVE SECOND LINE
         PUT   PRINTER                 * GET A PRINT BUFFER
         MVC   0(133,R1),HDR3          * MOVE THIRD LINE
         PUT   PRINTER                 * GET A PRINT BUFFER
         ZAP   LINECNTR,MAXLINES       * RESET LINE-COUNTER
         CP    FMT1CNT,=P'1'           * HOW MANY DATA SETS ON VOLUME
         BNL   FIRSTDTL                * AT LEAST ONE
         LR    R10,R1                  * NO FORMAT 1 DSCBS READ
         B     ENDUP                   * PRINT LAST TWO LINES
FIRSTDTL EQU   *
         MVI   0(R1),C'0'              * FIRST DETAIL LINE DOUBLE SPACE
PRINTBR  NOP   XDPRLPND                * BR IF MULTIPLE EXTENT
         EJECT
GETDSCB  LR    R10,R1                  * SAVE POINTER TO BUFFER
         USING DSNLINE,R10             * AND SET DSECT
         L     R15,RTNADDR             * ADDR OF ROUTINE TO READ DSCB
         BALR  R9,R15                  * GO AND DO IT
         MVC   LNDSN,DS1DSNAM          * MOVE DSNAME
         MVC   LNCREDT(88),LNEDMSK     * MOVE EDIT MASKS FOR OTHER FLDS
         MVC   DWORK+5(3),DS1CREDT     * CREATION DATE
         BAL   R9,DATECONV             * CONVERT DATE
         ED    LNCREDT,DWORK+4         * MM/DD/YY FORMAT
         OC    DS1REFD,DS1REFD         * CHECK FOR ZERO REFERENCE DATE
         BNZ   CNVREFDT                * NON-ZERO, GO CONVERT IT
         MVC   LNREFDT+1(8),LNREFDT    * ELSE CLEAR TO SPACES
         B     PARMTEST                * AND CONTINUE
CNVREFDT MVC   DWORK+5(3),DS1REFD      * REFERENCE DATE
         BAL   R9,DATECONV             * CONVERT DATE
         ED    LNREFDT,DWORK+4         * MM/DD/YY FORMAT
PARMTEST EQU   *
         CLC   PARM(3),=CL3'PDS'       * DIR BLKS ALLOC/USED REQUEST
         BNE   NOTPO2                  * NO, SKIP READ OF PDS DIRECTORY
         MVI   LNCREDT,C' '            * MOVE
         MVC   LNCREDT+1(8),LNCREDT    * SPACES
         MVI   LNREFDT,C' '            * MOVE
         MVC   LNREFDT+1(8),LNREFDT    * SPACES
         ZAP   DIRTOTAL(3),=PL3'0'     * ZERO COUNTER
         ZAP   DIRUSED(3),=PL3'0'      * ZERO COUNTER
         TM    DS1DSORG,B'00000010'    * PARTITIONED ORGANIZATION?
         BNO   NOTPO2                  * NO
         MVC   JFCBDSNM,DS1DSNAM       * YES, MOVE DSNAME
         OI    JFCBAREA+52,X'08'       * INDICATE NO JFCB WRITE BACK
         OPEN  (PDS,INPUT),TYPE=J      * OPEN PDS
         XC    DIRSTAT,DIRSTAT         * CLEAR DIRECTORY STATUS BYTE
GETDIR   EQU   *
         GET   PDS                     * READ PDS DIRECTORY BLOCKS
         AP    DIRTOTAL(3),=PL3'1'     * ADD TO TOTAL
         TM    DIRSTAT,X'80'           * END OF MEMBERS REACHED?
         BO    GETDIR                  * YES
         AP    DIRUSED(3),=PL3'1'      * NO, ADD TO USED
         LR    R5,R1                   * PT AT DIRECTORY BLOCK
         LH    R6,0(R5)                * # OF BYTES USED IN DIR BLOCK
         AR    R6,R5                   * A(END OF DIR BLOCK)
         LA    R5,2(R5)                * GO PAST BYTES USED FIELD
NAMETTR  EQU   *
         CR    R5,R6                   * END OF DIRECTORY BLOCK?
         BNL   GETDIR                  * YES
         CLC   0(8,R5),=8XL1'FF'       * END OF DIRECTORY MEMBERS?
         BE    MBREOF                  * YES
         SR    R1,R1                   * CLEAR A REGISTER
         NI    11(R5),X'1F'            * TURN OFF BITS 0,1,2
         IC    R1,11(R5)               * INDICATOR BYTE
         SLL   R1,1                    * HALFWORDS OF USER DATA
         AR    R5,R1                   * GO PAST USER DATA
         LA    R5,12(R5)               * GO PAST NAME/TTR
         B     NAMETTR                 * CHECK NEXT MEMBER
MBREOF   EQU   *
         OI    DIRSTAT,X'80'           * SET END OF MEMBERS FLAG
         B     GETDIR                  * AND CONTINUE
PDSEOF   EQU   *
         CLOSE PDS                     * DISCONNECT
         MVC   LNCREDT(6),DIRPATT      * EDIT MASK
         MVC   LNREFDT+2(6),DIRPATT    * EDIT MASK
         ED    LNCREDT(6),DIRTOTAL     * MOVE TO OUTPUT LINE
         ED    LNREFDT+2(6),DIRUSED    * MOVE TO OUTPUT LINE
NOTPO2   EQU   *
         TM    DS1DSORG,B'00000001'    * UNMOVABLE DATA?
         BNO   *+8                     * NO, SKIP NEXT INSTR
         MVI   LNDSORGU,C'U'           * INDICATE UNMOVABLE
         LH    R0,DS1DSORG             * LOAD DSORG INTO R0
         SLL   R0,16                   * AND SHIFT TO LHS OF REG
         LA    R1,7                    * LOAD # OF BITS TO TEST
DSORGLP  LTR   R0,R0                   * IS HI-ORDER BIT ON?
         BM    DSORGFND                * YES, ASSUME ONLY BIT SET
         SLL   R0,1                    * NO, SLIDE NEXT BIT TO SIGN
         BCT   R1,DSORGLP              * AND TEST THAT
DSORGFND SLL   R1,1                    * MULTIPLY R1 BY 2
         LA    R2,ORGTYPES(R1)         * USE IT TO ADDRESS TABLE
         MVC   LNDSORG,0(R2)           * MOVE CORRESPONDING DSORG
*        TM    DS1DSORG+1,DS1ORGAM     * VSAM?
         TM    DS1DSORG+1,DS1ACBM      * VSAM?                    *JLM*
         BNO   *+4+6                   * NO
         MVC   LNDSORG,=CL2'VS'        * YES
*        TM    DS1SMSFG,DS1PDSE        * PDSE?
*        BNO   *+4+6                   * NO
*        MVC   LNDSORG,=CL2'PE'        * YES
*        TM    DS1SMSFG,DS1PDSEX       * HFS?
*        BNO   *+4+6                   * NO
*        MVC   LNDSORG,=CL2'HF'        * YES
*        TM    DS1SMSFG,DS1STRP        * EXTENDED FORMAT DATASET?
*        BNO   *+4+4                   * NO
*        MVI   LNDSORGU,C'X'           * YES
* COMMENTED ABOVE 9 INSTRUCTIONS FOR MVS 3.8J                     *JLM*
         EJECT
         LA    R2,LNRECFM              * ADDRESS OUTPUT RECFM
         L     R0,DS1RECFM             * LOAD INPUT RECFM
         LA    R1,FMTYPES              * ADDRESS TABLE OF RECFM TYPES
         LA    R3,7                    * NO OF BITS TO TEST
         TM    DS1RECFM,B'11000000'    * FIRST CHECK FOR 'U'
         BNO   FMLOOP                  * NOT UNDEFINED
         MVI   0(R2),C'U'              * MOVE IN 'U'
         N     R0,=X'3FFFFFFF'         * OFF 'F' & 'V' BITS
         B     FMJUMP                  * AND JOIN LOOP
FMLOOP   LTR   R0,R0                   * TEST SIGN BIT
         BNM   FMEND                   * BIT IS OFF
         MVC   0(1,R2),0(R1)           * MOVE CORRESP CHAR
FMJUMP   LA    R2,1(R2)                * POINT TO NEXT OUTPUT SPOT
FMEND    EQU   *
         LA    R1,1(R1)                * POINT TO NEXT TYPE IN LIST
         SLL   R0,1                    * SHIFT OVER NEXT BIT
         BCT   R3,FMLOOP               * AND GO TEST IT
         LH    R0,DS1BLKL              * PICK UP BLKSIZE
         CVD   R0,DWORK                * CONVERT TO DECIMAL
         ED    LNBLKSI,DWORK+5         * MOVE TO OUTPUT
         LH    R0,DS1LRECL             * PICK UP LRECL
         CH    R0,=X'8000'             * IF LRECL = X'8000'
         BNE   NOT32K                  * THIS INDICATES  SPANNED RECDS
         MVC   LNLRECL+1(5),=C' >32K'      WITH RECD LENGTH > 32756
         B     CNVKEYLE                * AND THAT'S ALL
NOT32K   CVD   R0,DWORK                * OTHERWISE WE JUST
         ED    LNLRECL,DWORK+5         * MOVE VALUE TO OUTPUT
CNVKEYLE EQU   *
         SR    R0,R0                   * CLEAR REGISTER
         IC    R0,DS1KEYL              * INSERT KEYLEN
         CVD   R0,DWORK                * DECIMALISE
         ED    LNKEYLE,DWORK+6         * AND OUTPUT
         EJECT
* PICK UP SECONDARY ALLOCATION TYPE AND QUANTITY
         MVC   DWORK(4),DS1SCALO       * ALIGNMENT
         L     R2,DWORK                * LOAD SECONDARY ALLOC
         LA    R1,0(R2)                * SAVE IN R1 WITH HI-ORDER OFF
         SRL   R2,30                   * SHIFT OVER 2 BIT INDICATOR
         LA    R0,0(R2,R2)             * DOUBLE IT
         ALR   R2,R0                   * MAKE IT TRIPLE
         BNZ   NOTABSTR                * NOT ABSOLUTE TRACK
         MVC   LNSCALO(10),=C'     ABSTR' INDICATE ABSTR
         B     SECALEND                * FINISHED
NOTABSTR LA    R2,SECTYPES-3(R2)       * ADDRESS BLK, TRK OR CYL
         MVC   LNSCTYPE,0(R2)          * AND MOVE IT TO OUTPUT
         CVD   R1,DWORK                * CNVRT SEC ALLOC QTY
         ED    LNSCALO,DWORK+5         * MOVE TO OUTPUT
SECALEND EQU   *                       * THROUGH WITH SEC ALLOC
         SR    R0,R0                   * CLEAR A REG
         IC    R0,DS1NOEPV             * INSERT NO. OF EXTENTS
         CVD   R0,DWORK                * CONVERT TO DECIMAL
         ED    LNNOEXT,DWORK+6         * MOVE TO OUT-PUT LINE
         EJECT
         MVC   LASTBLK,DS1LSTAR        * FIRST SAVE LAST-BLK POINTER
* MAX OF 133 EXTENTS (1 FORMAT 1 AND 10 FORMAT 3 DSCB'S)
         XC    XTNTAREA(256),XTNAREA   * CLEAR AREA (133 *10 BYTES)
         XC    XTNTAREA+256(256),XTNAREA+256   *
         XC    XTNTAREA+512(256),XTNAREA+512   *
         XC    XTNTAREA+768(256),XTNAREA+768   *
         XC    XTNTAREA+1024(256),XTNAREA+1024 *
         XC    XTNTAREA+1280(50),XTNAREA+1280  *
         MVC   XTNTAREA(30),DS1EXT1    * MOVE 1ST 3 EXTENT DESCRIPTS
         LA    R5,10                   * LOAD MAX # OF F3'S TO READ
         LA    R6,XTNTAREA+30          * START OF F3'S IN AREA
CHKCHAIN OC    DS1PTRDS,DS1PTRDS       * IS THERE A FORMAT2 OR 3?
         BZ    NOCHAIN                 * NO, CHAINING NOT NECC
         MVC   VTOCFDAD+3(5),DS1PTRDS  * YES, SET ADDRESS
         BAL   R9,READDSCB+6           * AND READ FORMAT3
         CLI   DS1FMTID,C'3'           * IS IT A FORMAT 3?
         BNE   CHKCHAIN                * NO SO CHAIN AGAIN
         MVC   0(40,R6),DS1DSNAM+4     * MOVE NEXT 4 EXTENT DESCRIPTS
         MVC   40(90,R6),DS1DSSN       * MOVE NEXT 9 EXTENT DESCRIPTS
         LA    R6,130(R6)              * POINT TO NEXT SLOT IN AREA
         BCT   R5,CHKCHAIN             * GO SEE IF MORE
*
* NOW FOR SOMETHING TRICKY AFTER ALL THOSE STRAIGHTFORWARD EDITS -
* FIND THE NUMBER OF TRACKS ALLOCATED
*
NOCHAIN  EQU   *
         LA    R5,XTNAREA              * SET UP BEGINNING,
         LA    R6,10                       INCREMENT,
         LA    R7,XTNTAREA+1320              AND END POINTER FOR LOOP
         SR    R0,R0                   * ZERO REGISTER TO STORE RESULT
XTNTLOOP CLI   0(R5),X'00'             * IS THIS A VALID EXTENT?
         BE    XTNTEXIT                * NO
         LH    R1,6(R5)                * PICK UP CC FOR EXTENT END
         SH    R1,2(R5)                * SUBTRACT CC FOR EXTENT START
         MH    R1,DS4DEVSZ+2           * MULTIPLY BY # TRKS/CYL
         AH    R1,8(R5)                * ADD HH FOR EXTENT END
         SH    R1,4(R5)                * SUBTRACT HH FOR EXTENT START
         LA    R1,1(R1)                * ALLOW FOR LAST TRK OF EXTENT
         STH   R1,6(R5)                * SAVE # OF TRKS IN TABLE
         AR    R0,R1                   * ADD IN TO TOTAL TRKS
         BXLE  R5,R6,XTNTLOOP          * CHECK NEXT EXTENT
XTNTEXIT SR    R5,R6                   * POINT R5 BACK TO LAST EXTENT
         LR    R7,R5                   * RESET BXLE LIMIT
         CVD   R0,DWORK                * CNVERT NO. OF TRKS
         ED    LNNOTRKS,DWORK+5        * AND MOVE TO OUTPUT
         BNZ   CNVUSAGE                * OFF TO CONVERT % USAGE
         MVC   LNUSAGE+1(3),LNUSAGE      EXCEPT WHEN INDETERMINATE
         B     XDPRNT                  * BECAUSE ZERO ALLOC
         EJECT
CNVUSAGE LH    R3,LASTBLK              * PICK UP TT OF LAST BLOCK
         LA    R3,1(R3)                * ALLOW FOR LAST (PART-USED) TRK
         SR    R8,R8                   * ZERO REGISTER
         ICM   R8,3,DS4DEVTK           * LOAD HALFWORD (UP TO 64K)
         MR    R2,R8                   * CONVERT TO #BYTES USED
         LR    R1,R0                   * LOAD ODD-REGISTER OF PAIR
         MR    R0,R8                   * CONVERT TOTAL ALLOC
         LR    R0,R1                   * COPY TOTAL BYTES ALLOC
         SRL   R1,1                    * HALVE IT
         XC    DWORK(8),DWORK          * CLEAR AREA FOR SUBTRACT
         MVC   DWORK+6(2),LASTBLK+3    * MOVE FOR ALIGNMENT
         S     R3,DWORK+4              * SUBTRACT TRACK BALANCE
         M     R2,=F'100'              * MULT BY 100 FOR PERCENT
         AR    R3,R1                   * ROUND UP BY HALF TOTAL ALLOC
         DR    R2,R0                   * AND DIVIDE BY TOTAL ALLOCATION
         CVD   R3,DWORK                * CNVERT RESULT TO DECIMAL
         ED    LNUSAGE,DWORK+6         * THEN MOVE TO OUTPUT LINE
XDPRNT   LA    R5,XTNTAREA             * RESET PNTR TO WORKAREA
XDPRLOOP SR    R0,R0                   * CLEAR WORK REG
         IC    R0,1(R5)                * OBTAIN EXTENT NUMBER (M)
         CVD   R0,DWORK                * CONVERT TO DECIMAL
         ED    LNXDM,DWORK+6           * MOVE TO LINE
         LH    R15,2(R5)               * PICK UP CYL ADDRESS IN HEX
         CVD   R15,DWORK               * GET IN PACKED DECIMAL
         MVC   CCCCWORK(6),MASKCCCC    * USE EDIT MASK FOR 3380 E/K
         ED    CCCCWORK(6),DWORK+5     * EDIT 5 DIGIT CYLINDER ADDRESS
         MVC   LNXDCCHH(4),CCCCWORK+2  * SET CYL ADDRESS IN PRINT LINE
         LH    R15,4(R5)               * PICK UP TRK ADDRESS IN HEX
         CVD   R15,DWORK               * GET IN PACKED DECIMAL
         ED    LNXDCCHH+4(4),DWORK+6   * SET TRK ADDRESS IN PRINT LINE
         SR    R0,R0                   * ZERO REGISTER
         ICM   R0,3,6(R5)              * PICK UP # TRKS
         CVD   R0,DWORK                * CONVERT
         ED    LNXD#TRK,DWORK+5        * AND EDIT TO LINE
         BXH   R5,R6,PRNTDSCB          * FINISH IF ALL EXTENTS DONE
         MVI   PRINTBR+1,X'F0'         * MAKE A BRANCH
         B     PRNTDSCB                * GO PRINT A LINE
XDPRLPND MVI   PRINTBR+1,X'00'         * RESET TO NOP
         LR    R10,R1                  * SET BUFFER POINTER
         MVI   LNCC+1,C' '             * INITIALISE
         MVC   LNCC+2(112),LNCC+1      * TO SPACES
         MVC   LNXDM(19),LNEXTDSC      * MOVE IN NEW EDIT MSK
         B     XDPRLOOP                * CONTINUE WITH NEXT EXTENT
         EJECT
READDSCB MVC   VTOCFDAD,VTOCNEXT       * MOVE ADDRESS OF NEXT DSCB
         READ  VTOCDECB,DIR,VTOC,DS1FMTID,'S',DS1DSNAM,                *
               VTOCFDAD,VTOCNEXT
         CHECK VTOCDECB                * WAIT FOR IT TO ARRIVE
         TM    VTOCDECB+1,B'10000100'  * NO RECD FND / EOF
         L     R15,EODADDR             * PICK UP EODAD
         BCR   7,R15                   * GO THERE IF NRF OR EOF
POINTF5  EQU   *
         MVC   VTOCNEXT,VTOCFDAD       * MOVE OLD DISC ADDRESS
         SR    R15,R15                 * CLEAR R15
         SR    R1,R1                   * AND R1
         LA    R0,1                    * SET R0 TO 1
         IC    R15,VTOCNEXT+7          * PICK UP RECD NO. ON TRK
         IC    R1,DS4DEVDT             * PICK UP MAX RECDS PER TRK
         BXH   R15,R0,NEXTTRK          * BRANCH IF HIGH
         STC   R15,VTOCNEXT+7          * ELSE SAVE BUMPED VALUE
         BR    R9                      * THEN RETURN
NEXTTRK  MVI   VTOCNEXT+7,1            * RESET R TO 1
         LH    R15,VTOCNEXT+5          * PICK UP CC
         LH    R1,DS4DEVSZ+2           * AND NO. TRKS/CYL
         BCTR  R1,0                    * MINUS ONE
         BXH   R15,R0,NEXTCYL          * BUMP AND TEST
         STH   R15,VTOCNEXT+5          * SAVE INCREMENTED VALUE
         BR    R9                      * AND EXIT
NEXTCYL  AH    R0,VTOCNEXT+3           * ADD 1 TO CC
         SLL   R0,16                   * INSERT ZEROS ON RIGHT
         ST    R0,VTOCNEXT+3           * SAVE NEW CCHH
         BR    R9                      * THEN RETURN
         EJECT
READFMT1 EQU   *                       * READ A FORMAT 1
         LR    R3,R9                   * SAVE LINK REG
TSTHPCHR CLC   VTOCNEXT+3(5),DS4HPCHR  * IS ADDR HIGHER THAN
*                                          HIGHEST FORMAT 1 ?
         L     R15,EODADDR             * PICK UP EODAD
         BCR   2,R15                   * GO THERE IF FINISHED
         BAL   R9,READDSCB             * READ A DSCB
         CLI   DS1FMTID,C'1'           * IS IT A FORMAT1?
         BNE   TSTHPCHR                * IF NO, TRY AGAIN
         AP    FMT1CNT,=P'1'           * INCLUDE THIS DSCB IN COUNT
         LR    R9,R3                   * RESTORE LINK
         BR    R9                      * AND RETURN
         EJECT
READTABL EQU   *
         LA    R4,50(R4)               * BUMP POINTER
         C     R4,TABLEND              * FINISHED?
         BH    ENDUP                   * YES
         MVC   VTOCFDAD+3(5),45(R4)    * MOVE CCHHR FROM TABLE
         B     READDSCB+6              * GO READ NEXT DSCB
         EJECT
ENDUP    ED    FLINE1CT,FMT1CNT+1      * SET NO OF DATA SETS IN PRT LNE
         MVC   0(133,R10),FLINE1       * SET PRINT LINE PROPER
         L     R11,VTOCDECB+8          * PT @ DCB
         L     R3,44(R11)              * PICK UP DEB ADDR FROM DCB
         L     R0,32(R3)               * PICK UP UCB ADDR FROM DEB
         LA    R1,MESSAGE              * LSPACE MESSAGE AREA
         SVC   78                      * LSPACE SVC
         PACK  DBLWD1+5(3),TOTCYLS     * CONVERT TO PACKED DECIMAL
         PACK  DBLWD2+5(3),TOTTRKS     * CONVERT TO PACKED DECIMAL
         ED    FLINE2C,DBLWD1+5        * SET NO OF CYLS IN PRT LINE
         ED    FLINE2T,DBLWD2+5        * SET NO OF TRKS IN PRT LINE
         PUT   PRINTER                 * GET BUFFER POSITION
         MVC   0(133,R1),FLINE2        * MOVE INTO BUFFER
         CLOSE (VTOC,,PRINTER)         * CLOSE FILES
         L     R13,4(R13)              * RESTORE R13
         RETURN (14,12),RC=0           * RETURN TO CALLER
         EJECT
* DATE CONVERSION - DATE IN FORMAT YDD IS ASSUMED TO BE IN LAST
* THREE BYTES OF DWORK
DATECONV EQU   *                       * CONVERT DATE TO DECIMAL
         LA    R0,28                   * LOAD 28 DAYS FOR FEBRUARY
         TM    DWORK+5,3               * TEST FOR LEAP YEAR
         BNZ   *+8                     * NO, SKIP NEXT INSTR
         LA    R0,29                   * YES, 29 DAYS IN FEB
         STH   R0,DATETABL+2           * STORE FEB DAYS
         LA    R15,DATETABL            * POINT TO TABLE START
         LA    R1,DATETABL+22          * AND TABLE END
         LA    R0,2                    * LOAD BXLE INCREMENT
         LH    R14,DWORK+6             * PICK UP # DAYS IN YEAR
DATELOOP SH    R14,0(R15)              * SUBTRACT TABLE ENTRY
         BNP   MNTHFND                 * IF -VE, HAVE HIT REQD MONTH
         BXLE  R15,R0,DATELOOP         * ELSE LOOP AGAIN
         XC    DWORK,DWORK             * IF NO MATCH, THEN ERROR
         BR    R9                      * SO RETURN
MNTHFND  AH    R14,0(R15)              * ALLOW FOR LAST SUBTRACT
         S     R15,=A(DATETABL-2)      * FIND TABLE DISPLACEMENT
         MH    R15,=H'5000'            * OBTAIN MONTH*10000
         MH    R14,=H'100'             * AND DAY*100
         SR    R0,R0                   * CLEAR R0
         IC    R0,DWORK+5              * GET YEAR NO. 000000YY
         C     R0,=F'100'              * Y2K DATE?
         BL    *+8                     * NO
         S     R0,=F'100'              * YES, AVOID OVERFLOW INTO DD
         AR    R0,R14                  * ADD DAY      0000DDYY
         AR    R0,R15                  * AND MONTH    00MMDDYY
         CVD   R0,DWORK                * CONVERT      0MMDDYYC
         MVO   DWORK,DWORK             * AND SHIFT    MMDDYYCC
         BR    R9                      * RETURN FOR EDIT
DATETABL DC    H'31,28,31,30,31,30'    * TABLE USED TO FIND
         DC    H'31,31,30,31,30,31'    * THE NUMBER OF THE MONTH
         PUSH  USING                   * SAVE USING STATUS
         DROP  ,                       * DROP ALL BASE REGS
         EJECT
IOERR    EQU   *                       * SYNAD ROUTINE
         USING *,R15                   * R13 IS CLOBBERED
         SYNADAF ACSMETH=BDAM          * PERFORM SYSTEM ERROR ANALYSIS
         MVC   SYNERMSG(60),68(R1)     * MOVE USEFUL PART OF SYSMSG
         MVC   SYNADVOL,JFCBVOLS       * SET VOL SER NO IN MESSAGE
         WTO   MF=(E,SYNADMSG)         * ISSUE ERROR MESSAGE
         BALR  R15,0                   * R15 DESTROYED BY WTO
         USING *,R15                   * SO BASE MUST BE RESET
         MVI   DS1FMTID,X'00'          * ENSURE BAD DSCB IGNORED
         SYNADRLS ,                    * RESTORE R13
         DROP  R15                     * RELEASE R15
         BR    R14                     * RETURN TO CHECK ROUTINE
         POP   USING                   * RESTORE USING STATUS
         EJECT
DBLWD1   DC    D'0'                    * WORK AREA FOR FREE CYL COUNT
DBLWD2   DC    D'0'                    * WORK AREA FOR FREE TRK COUNT
DWORK    DC    D'0'                    * WORKAREA
VTOCFDAD DC    D'0'                    * FULL DISC ADDR - MBBCCHHR
TABLADDR DC    A(0)                    * ADDRESS OF TABLE OF DSCB'S
TBLWIDTH DC    A(50)                   * SIZE OF TABLE ENTRY
TABLEND  DC    A(0)                    * END OF TABLE
RTNADDR  DC    A(READTABL)             * DEFAULT ROUTINE
EODADDR  DC    A(VTOCEOD)              * END-OF-FILE ROUTINE
FMT1CNT  DC    PL4'0'                  * NO OF FORMAT 1 DSCBS READ
LASTBLK  DC    XL5'00'                 * SAVEAREA FOR LAST BLOCK PNTR
VTOCNEXT DC    XL8'00'                 * MUST ALIGN AT FULLWD+1
LINECNTR DC    P'000'                  * LINE COUNTER
MAXLINES DC    P'54'                   * LINES PER PAGE
PAGECNTR DC    P'000'                  * PAGE COUNTER
PARM     DC    CL3' '                  * JCL PARM HOLD AREA
HALFWD   DC    H'0'                    * WORK AREA FOR ALIGNMENT
DIRSTAT  DC    XL1'00'                 * PDS DIR STATUS
DIRTOTAL DC    PL3'0'                  * PDS DIR BLKS ALLOC
DIRUSED  DC    PL3'0'                  * PDS DIR BLKS USED
DIRPATT  DC    X'402020202120'         * EDIT MASK FOR DIR BLKS
MASKCCCC DC    X'402020202120'         * EDIT MASK FOR CYLINDERS
CCCCWORK DC    CL6' '                  * WORK AREA FOR CYLINDER EDIT
FMTYPES  DC    CL8'FVTBSAM'            * PERMISSIBLE RECFM'S
ORGTYPES DC    C'  POMQCQCXDAPSIS'     * DSORG TYPES
SECTYPES DC    C'BLKTRKCYL'            * TYPES OF ALLOCATION
LNEDMSK  DS    0CL88                   * EDIT MASK FOR DSN OUTPUT LINE
         DC    2X'402120612020612020'  * CREATION/LAST REF DATE
         DC    C' '
         DC    CL3' '                  * DSORG(U)
         DC    C' '
         DC    CL5' '                  * RECFM
         DC    X'402020202020'         * BLKSIZE
         DC    X'402020202020'         * LRECL
         DC    X'40202020'             * KEYLEN
         DC    C' '
         DC    X'402020202120'         * TRKS ALLOC
         DC    X'40202120'             * PERCENT USE
         DC    X'40202120'             * NUMBER OF EXTENTS
         DC    X'402020202120'         * SECONDARY EXTENT QUANTITY
         DC    C' '
         DC    CL3' '                  * SECONDARY EXTENT TYPE
LNEXTDSC DS    0CL19                   * EXTENT DESCRIPTION
         DC    X'40202120'             * EXTENT NUMBER
         DC    C' '
         DC    X'4020212040202120'     * CCHH OF EXTENT
         DC    X'402020202120'         * NO OF TRKS IN EXTENT
         PRINT NOGEN
PRINTER  DCB   DDNAME=SYSPRINT,DSORG=PS,MACRF=PL,LRECL=133,            *
               RECFM=FBA
VTOC     DCB   DDNAME=SYSUT1,DSORG=DA,MACRF=RIC,OPTCD=A,               *
               SYNAD=IOERR,RECFM=FS,BLKSIZE=96,KEYLEN=44,EXLST=VTOCXLST
PDS      DCB   DDNAME=SYSUT1,                                          *
               RECFM=U,                                                *
               BLKSIZE=256,                                            *
               EODAD=PDSEOF,                                           *
               DSORG=PS,                                               *
               MACRF=GL,                                               *
               EXLST=VTOCXLST
OPENVTOC OPEN  (VTOC,INPUT),MF=L       * LIST FOR E-TYPE OPEN, RDJFCB
VTOCXLST DC    X'87',AL3(JFCBAREA)     * JFCB ENTRY IN EXIT LIST
SYNADMSG DC    AL2(JFCBDSNM+44-*,0)    * WTO RECD DESCRIPTOR WORD
         DC    C'VTOCLIST - I/O ERROR READING VTOC ON '
SYNADVOL DC    C'******'
         DC    C', SYNADAF INFO ='
SYNERMSG DC    CL16' '                 * INITIALISE TO SPACES
         ORG   *-4                     * BACKSPACE
         DS    0F                      * ALIGN TO FULLWORD
JFCBAREA DS    0CL176                  * SPACE FOR VTOC JFCB
JFCBDSNM DS    CL44                    * VTOC DSN - ALSO SYNAD WRKAREA
         DS    CL132                   * SPACE FOR REST OF JFCB
JFCBVOLS EQU   JFCBAREA+118            * VOLUME SERIAL NO.
         EJECT
         PRINT GEN
         IECSDSL1 (1)                  * FORMAT 1 DSCB
DS4DATA  DS    0CL71
         IECSDSL1 (4)                  * FORMAT 4 DSCB
         EJECT
MESSAGE  DC    30C'0'                  * OUTPUT AREA FOR LSPACE SVC
         ORG   MESSAGE
         DS    CL6
TOTCYLS  DS    CL4                     * FREE CYLINDERS
         DS    CL1
TOTTRKS  DS    CL4                     * FREE TRACKS
         ORG   ,
HDR1     DC    133C'*'
         ORG   HDR1
         DC    C'1*** CONTENTS OF '
HDR1FILE DC    C'THE VOLUME TABLE OF CONTENTS'
         DC    C' ON VOLUME '
HDR1VOL  DC    C'******'
         DC    C' *** DATE ='
HDR1DATE DC    X'402120612020612020'
         DC    C' *** TIME ='
HDR1TIME DC    X'4021204B20204B202040'
         ORG   HDR1+120
         DC    C' PAGE'
         DC    X'4020202040'
         ORG   HDR1+133
HDR2     DC    CL33'-                                              '
         DC    C'               DATE     DATE   DS-        BLK-    '
         DC    C'   KEY- TRKS   %  NO.   SEC-ALLOC EXTENT-DESCRIPTN.'
HDR3     DC    CL33'    DATASET NAME                               '
         DC    C'              CREATED  LASTREF ORG RECFM  SIZE LRE'
         DC    C'CL LEN  ALLOC USE EXTS  QTY TYPE  M  CYL TRK #TRKS'
HDR2P    DC    CL33'-                                              '
         DC    C'             DIRECTORY  BLOCKS DS-        BLK-    '
         DC    C'   KEY- TRKS   %  NO.   SEC-ALLOC EXTENT-DESCRIPTN.'
HDR3P    DC    CL33'    DATASET NAME                               '
         DC    C'             ALLOCATED  USED   ORG RECFM  SIZE LRE'
         DC    C'CL LEN  ALLOC USE EXTS  QTY TYPE  M  CYL TRK #TRKS'
FLINE1   DC    CL15'0 *** THERE ARE'
FLINE1CT DC    X'402020202120'
         DC    CL112' DATA SETS ON THIS VOLUME.'
FLINE2   DC    CL15'  *** THERE ARE'
FLINE2C  DC    XL6'402020202120'
         DC    CL21' EMPTY CYLINDERS PLUS'
FLINE2T  DC    XL6'402020202120'
         DC    CL85' EMPTY TRACKS ON THIS VOLUME.'
         LTORG
         DC    0F'0'                   * ENSURE XTNTAREA ALIGNED
XTNTAREA DC    30X'00'                 * EXTENTS 1-3   (F1)
         DC    1300X'00'               * EXTENTS 4-133 (F3, 10 MAX)
XTNAREA  EQU   XTNTAREA
         EJECT
HDRLINE  DSECT
         DS    CL125
HDPAGCNT DS    XL4
DSNLINE  DSECT
LNCC     DS    C                       * CARRIAGE CONTROL BYTE
LNDSN    DS    CL44                    * DATASET NAME
LNCREDT  DS    CL9                     * CREATION DATE
LNREFDT  DS    CL9                     * LAST REFERENCE DATE
         DS    C
LNDSORG  DS    CL2                     * DSORG
LNDSORGU DS    C                       * UNMOVABLE FLAG
         DS    C
LNRECFM  DS    5C                      * RECFM
LNBLKSI  DS    CL6                     * BLKSIZE
LNLRECL  DS    CL6                     * LRECL
LNKEYLE  DS    CL4                     * KEYLEN
         DS    C
LNNOTRKS DS    CL6                     * TOTAL NO. OF TRKS ALLOCATED
LNUSAGE  DS    CL4                     * PERCENTAGE USE OF ALLOC SPACE
LNNOEXT  DS    CL4                     * NUMBER OF EXTENTS
LNSCALO  DS    CL6                     * SECONDARY ALLOCATION QTY
         DS    C
LNSCTYPE DS    CL3                     * TYPE OF ALLOC - TRK/CYL/BLK
LNXDM    DS    CL4                     * EXTENT-DESCRIPTION - M
         DS    C
LNXDCCHH DS    CL8                     * EXTENT DESCRIPTION - CCHH
LNXD#TRK DS    CL6                     * EXTENT DESCRIPTION - NO OF TRK
         END
//LKED.SYSLMOD DD DSN=SYS2.LINKLIB,DISP=SHR                             00090000
//SYSIN DD *                                                            00100000
  NAME VTOCLIST(R)                                                      00110000
//                                                                      00120000
