//ULXL01 JOB (JOB),
//             'INSTALL ULXL01',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//*
//*  Installs MLIB
//*
//CLISTS   EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYSGEN.ISPF.MLIB,DISP=SHR
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=ULXM01
ULXM010  ' '

ULXM011A 'VOLUME NOT MOUNTED'

ULXM011B 'INVALID OPTION'

ULXM011C 'NO EXTENTS'

ULXM011D 'TBCREATE ERROR'

ULXM011E 'TBADD ERROR'

ULXM012A 'NONINDEXED VTOC'

ULXM012B 'RC 0 BUT NULL EXTENT FOUND'

ULXM012C 'RC 4-32 BUT NO NULL EXTENT'

ULXM012D 'CVAFDSM FAILED'

@@
//*
//*  Installs PLIB
//*
//CLISTS   EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DSN=SYSGEN.ISPF.PLIB,DISP=SHR
//SYSUT1   DD  DATA,DLM=@@
./ ADD NAME=ULXH02
%TUTORIAL------------------- DISK SPACE INFORMATION ----------------------------
+
+  The disk space information panel shows how much space is available
+  on a specified disk.
+
+  Cylinders available --------- The number of cylinders containing no
+                                used tracks.
+  Tracks available ------------ The number of unused tracks that are
+                                in partially used cylinders.
+  Total tracks available ------ The number of unused tracks including
+                                all unused cylinders.
+
+  Extents of free space ------- An extent is a group of adjacent tracks.
+                                This is the number of groups of unused
+                                tracks on the volume.
+
+  Largest single extent ------- The largest group of adjacent unused
+                                tracks.
+
+  DSCB's available in VTOC ---- The maximum number of additional data
+                                sets that this volume can have. The
+                                number of unused entries in the volume
+                                table of contents.
)END
./ ADD NAME=ULXP01
%--------------------------- DISK SPACE INFORMATION ----------------------------
+COMMAND ===>_ZCMD                                                     +
%
%Display information about available space on a disk volume.
%
%     + VOLUME ===>_ULXV01+
%
)INIT
  .CURSOR = ULXV01
)END
./ ADD NAME=ULXP02
%--------------------------- DISK SPACE INFORMATION ----------------------------
+ COMMAND =======>_ZCMD                                                +
+ NEXT VOLUME ===>_ULXV02 +
+                              Volume ---%&ULXV01
+                              Device ---%&ULXUNIT
+
+    Tracks per cylinder -------------%&ULXTPC  +Cylinders ------%&ULXCPV
+
+    Cylinders available -------------%&ULXCYL
+    Tracks available ----------------%&ULXTRK
+    Total Tracks available ----------%&ULXATOT +Percent used ---%&ULXPCU
+
+    Extents of free space -----------%&ULXEXT+Enter L here to List Extents
+                                              S for Sorted-by-Size  ===>_ULXOPT
+    Largest single extent:
+      Cylinders ---------------------%&ULXLRGC
+      Tracks ------------------------%&ULXLRGT
+      Total Tracks ------------------%&ULXLTOT
+
+    DSCB's available in VTOC --------%&ULXDSREC
+       According to Format 4 ---%&ULXDSROS +VTOC tracks ---%&ULXTRACS
+       According to Index ------%&ULXDSRIX +VTOC Extent ---%&ULXVTOC1%&ULXVTOC2
)INIT
  .CURSOR = ULXV02
  .HELP = ULXH02
  &ZHTOP = ULXH01     /* TUTORIAL TABLE OF CONTENTS */
  &ZHINDEX = ULXH00   /* TUTORIAL INDEX - 1ST PAGE  */
)PROC
  VER (&UXLOPT,LIST,L,S,MSG=ULXM011B)
)END
./ ADD NAME=ULXP03
)ATTR
  @ TYPE(OUTPUT) INTENS(LOW)
)BODY
%------------- DISK SPACE INFORMATION ------------------------------------------
+ COMMAND =======>_ZCMD                                        %SCROLL ===>_TBS
+ Volume%&ULXV01 +Device%&ULXUNIT +Trk/Cyl%&ULXTPC +Extents%&ULXEXT
+
+      XXXX = Rel Trk of 1st Trk    YYYY = No. of Cyls    ZZ = No. of Trks
+
+SEQNO XXXXYYYYZZ     CYLINDERS   TRACKS   TOTAL     BEGIN CCHH  END CCHH
+----- ----------     ---------   ------  -------    ---------- ----------
)MODEL
@Z    @Z                @Z        @Z      @Z         @Z         @Z
)INIT
  .ZVARS = '(TBSEQ TBEXT TBCYL TBTRA TBTRK TBBEG TBEND)'
  &TBS = HALF
)END
@@
//ASMFCL EXEC ASMFCL,PARM.ASM='NODECK,OBJECT,NOXREF,NORLD',
//             PARM.LKED='LIST,MAP,NCAL,RENT,REUS,REFR',
//             COND.LKED=(0,NE,ASM)
//ASM.SYSIN DD DATA,DLM=@@
         TITLE '   U L X L 0 1   '                                              
***********************************************************************         
*                                                                     *         
*        'ULXL01' - AN ISPF DIALOG SERVICES PROGRAM                   *         
*         FOR DISPLAYING AVAILABLE DISK SPACE.                        *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
* WRITTEN BY BILL GODFREY, PRC INC.                                             
*  (PRC INC. OF MCLEAN, VIRGINIA, WAS FORMERLY PLANNING RESEARCH CORP.)         
* CURRENT INSTALLATION:                                                         
*  NOAA (NATIONAL OCEANIC AND ATMOSPHERIC ADMINISTRATION),                      
*  5200 AUTH ROAD, CAMP SPRINGS, MARYLAND 20746                                 
* DATE WRITTEN. MAY 24 1985.                                                    
* DATE UPDATED. APRIL 25 1991.                                                  
* ATTRIBUTES. RE-ENTRANT.                                                       
* DISCLAIMER: NO GUARANTEE; NO WARRANTY; INSTALL/USE AT YOUR OWN RISK.          
* REQUIRED PANELS.    ULXP01, ULXP02, ULXP03.                                   
* REQUIRED MESSAGES.  ULXM01.                                                   
* REQUIRED CLISTS.    NONE.                                                     
* MODULES LOADED. ISPEXEC.                                                      
* DESCRIPTION.                                                                  
*         THIS SPF DIALOG PROGRAM DISPLAYS INFORMATION ABOUT                    
*         AVAILABLE SPACE ON A DISK VOLUME, FROM THE FORMAT 5                   
*         DSCB'S OR THE VTOC INDEX.                                             
*                                                                               
*         SOME OF THE VARIABLES THAT ARE VDEFINED ARE USED ONLY                 
*         FOR DEBUGGING AND DO NOT APPEAR ON THE NORMAL PANEL.                  
*         THEY COULD BE ADDED TO THE PANEL FOR DEBUGGING.                       
*                                                                               
*         THE FIRST 3 CHARACTERS OF THE PANEL NAMES MAY BE                      
*         OVERRIDDEN BY PASSING A PARM OF 'PFX=XXX'                             
*         WHERE XXX ARE THE 3 NEW CHARACTERS.                                   
*         THIS ALSO OVERRIDES THE FIRST 3 CHARACTERS                            
*         OF THE MESSAGE ID'S.  THE MESSAGE ID'S WITHIN THE                     
*         MESSAGE MEMBER MUST CORRESPOND WITH THE MEMBER NAME,                  
*         SO IF YOU RENAME A MESSAGE MEMBER YOU MUST CHANGE                     
*         THE MESSAGE ID'S WITHIN THAT MEMBER.                                  
*                                                                               
* LOG OF CHANGES.                                                               
*  15APR91 - RECOGNIZE 3390. USE LAST 2 BYTES OF DEVICES FOR ALT CYL.           
*            ADD XA UCB SCAN. CREATE VARIABLES ULXCPV ULXPCU.                   
*                                                                       *MVS38J 
*  21JAN2020 Modified by Larry Belmontes to enable for execution        *MVS38J 
*                                under MVS 3.8J / ISPF 2.x              *MVS38J 
*                                                                       *MVS38J 
*            https://www.ShareABitofIT.net/ULXL01-in-MVS38J/            *MVS38J 
*                                                                       *MVS38J 
*          - ISPF 2.x is Wally Mclaughlin's ISPF-like product           *MVS38J 
*          - MVS 3.8J is the public domain MVS OS version               *MVS38J 
*          - No application functional enhancements as part of          *MVS38J 
*            enabling to execute under MVS 3.8J                         *MVS38J 
*          - To preserve the original author's source code,             *MVS38J 
*            conditional assembly directives are inserted               *MVS38J 
*            to exclude Indexed VTOC source code and macros             *MVS38J 
*            not supported in MVS 3.8J                                  *MVS38J 
*          - Syntax differences between IBM ISPF and ISPF 2.x           *MVS38J 
*            for the VDEFINE service are accomodated via conditional    *MVS38J 
*            assembly directive for inclusion of logic to remove        *MVS38J 
*            parentheses in variable names (field VDEFNAME)             *MVS38J 
*          - Tested with Volker Bandke's MVS CD - MVS38J TK3            *MVS38J 
*            using Hercules 3.13 / Win 10 Pro w/ ISPF 2.1               *MVS38J 
*          - Tested with TK4- Update 8 (Juergen Winkelmann)             *MVS38J
*            using Hercules 4.00 / Win 10 Pro w/ ISPF 2.1               *MVS38J 
*                                                                               
* NOTE: AN EARLIER VERSION OF THIS PROGRAM, BY THE SAME AUTHOR, WAS             
*  DISTRIBUTED ON THE CBT TAPE (FILES 88 AND 137) WITH THE AUTHOR'S             
*  NAME REMOVED.                                                                
*                                                                               
         SPACE                                                                  
         LCLC  &MVS38J,&ISPFW      Define conditional assembly flags    *MVS38J
*                                                                       *MVS38J
*********************************************************************** *MVS38J
*        MVS 3.8J OS Flag                                             * *MVS38J
*********************************************************************** *MVS38J
&MVS38J  SETC  'YES'     YES - MVS 3.8J OS                              *MVS38J
*                        NO  - Other OS                                 *MVS38J
*                                                                       *MVS38J
*                                                                       *MVS38J
*********************************************************************** *MVS38J
*        ISPF 2.x Product from Wally Mclaughlin                       * *MVS38J
*********************************************************************** *MVS38J
&ISPFW   SETC  'YES'     YES - ISPF product from Wally Mclaughlin       *MVS38J
*                        NO  - Other ISPF product                       *MVS38J
*                                                                       *MVS38J
ULXL01   START                                                                  
         USING *,R10,R11                                                        
         B     @PROLOG-*(,15)                                                   
         DC    AL1(11),CL11'ULXL01 1.1 '                                        
         DC    CL16' &SYSDATE &SYSTIME '                                        
@SIZE    DC    0F'0',AL1(1),AL3(@DATAL)                                         
@PROLOG  STM   14,12,12(R13)       SAVE REGISTERS                               
         LR    R10,R15             LOAD BASE REGISTER                           
         LA    R15,1                                                            
         LA    R11,4095(R15,R10)                                                
         LR    R2,R1               PARM POINTER                                 
         L     R0,@SIZE            WORKAREA SUBPOOL AND LENGTH                  
         GETMAIN R,LV=(0)                                                       
         LR    R9,R1               INITIALIZE WORKAREA POINTER                  
         SPACE 1                                                                
         LR    R0,R1               AREA TO BE CLEARED                           
         L     R1,@SIZE            LENGTH TO BE CLEARED                         
         SLR   R15,R15             ZERO PAD AND 'FROM' LENGTH                   
         MVCL  R0,R14              ZERO IT ALL                                  
         SPACE 1                                                                
         ST    R13,4(,R9)          CHAIN SAVEAREA                               
         ST    R9,8(,R13)          CHAIN SAVEAREA                               
         LR    R13,R9              UPDATE SAVEAREA POINTER                      
         USING @DATA,R9                                                         
         SPACE 1                                                                
         AGO   .ESTAE1                                                          
***********************************************************************         
*                                                                     *         
*         SET UP ESTAE ENVIRONMENT                                    *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         STM   R10,R11,@BASES                                                   
         MVC   ESTAEL(ESTAELL),ESTAEM                                           
         LA    R8,ESTAEX                                                        
         ESTAE (R8),TERM=YES,PARAM=(R9),MF=(E,ESTAEL)                           
         LTR   R15,R15                                                          
         BNZ   EXIT12                                                           
.ESTAE1  ANOP                                                                   
         SPACE 1                                                                
***********************************************************************         
*                                                                     *         
*         GET OPTIONAL PREFIX FOR PANEL NAMES                         *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         MVC   PFX,=C'ULX'                                                      
         L     R1,0(,R2)                                                        
         LH    R15,0(,R1)          LENGTH OF PARM                               
         LTR   R15,R15             IS THERE A PARM                              
         BZ    NOPARM              NO, BRANCH                                   
         CH    R15,=H'4'           LONG ENOUGH FOR PFX=                         
         BL    NOPARM              NO                                           
         CLC   2(4,R1),=C'PFX='    IS IT PFX=                                   
         BNE   NOPARM              NO                                           
         SH    R15,=H'4'           GET LENGTH OF PFX                            
         BZ    NOPARM              BRANCH IF NULL                               
         CH    R15,=H'3'           IS REMAINING LENGTH 3                        
         BNE   NOPARM              NO                                           
         MVC   PFX,6(R1)           YES, CHANGE PANEL AND MESSAGE NAMES          
NOPARM   EQU   *                                                                
         SPACE 1                                                                
***********************************************************************         
*                                                                     *         
*         GET ENTRY POINT OF ISPLINK                                  *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LOAD  EP=ISPLINK,ERRET=EXIT12                                          
         ST    R0,ISPEXEC                                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         MAKE 'ULXV01' A DEFINED VARIABLE                            *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXV01)'                                         
         MVC   VOLUME,=CL6' '                                                   
         LA    R0,VOLUME                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'6'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         SEE WHAT CONTROL-ERRORS-RETURN DOES                         *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
*              THIS KEEPS US IN CONTROL IF THE END KEY (PFK3) IS USED           
         SPACE                                                                  
         LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'CONTROL'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,ERRORS                                                        
         MVC   ERRORS,=CL8'ERRORS'                                              
         ST    R0,4(,R1)                                                        
         LA    R0,RETURN                                                        
         MVC   RETURN,=CL8'RETURN'                                              
         ST    R0,8(,R1)                                                        
         OI    8(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         DISPLAY PANEL P01 AND WAIT FOR REPLY                        *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
PAN01    LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'DISPLAY'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,PANEL                                                         
         MVC   PANEL,=CL8'ULXP01'                                               
         MVC   PANEL(3),PFX                                                     
         ST    R0,4(,R1)                                                        
         OI    4(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
*              QUESTION: WHAT HAPPENS IF REPLY IS PFK 3?                        
ERRX01   LTR   R15,R15                                                          
         BZ    OKPAN01                                                          
*        LA    R1,=C'P01FAIL'                                                   
*        LA    R0,7                                                             
*        SVC   93                                                               
         B     EXIT0                                                            
OKPAN01  EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         REPEAT DISPLAY IF NOTHING ENTERED                           *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         CLC   VOLUME,=CL6' '                                                   
         BE    PAN01                                                            
         MVC   VOLSER,VOLUME                                                    
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         FIND THE UCB FOR THE SPECIFIED VOLUME                       *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
REREAD   EQU   *                                                                
         L     R15,16              CVTPTR                                       
         TM    116(R15),X'80'      MVS/XA                          .XA.         
         BO    UCBXA               YES                             .XA.         
         L     R15,40(,R15)        CVTILK2                                      
         B     *+8                                                              
FINDLOOP LA    R15,2(,R15)                                                      
         LH    R1,2(,R15)          GET UCB ADDRESS                              
         N     R1,=A(X'0000FFFF')  CANCEL EFFECTS OF LEFTMOST BIT               
         BZ    FINDLOOP            IGNORE IF ADDRESS IS ZERO                    
         C     R1,=A(X'0000FFFF')  END OF LIST                                  
         BE    FAILUCB                                                          
         CLI   18(R1),X'20'        DASD                                         
         BNE   FINDLOOP            NO                                           
         TM    3(R1),X'80'         ONLINE?                                      
         BZ    FINDLOOP            NO                                           
         CLC   28(6,R1),VOLSER     VOLUME MATCH?                                
         BNE   FINDLOOP            NO                                           
         B     FOUNDUCB                                                         
UCBXA    EQU   *                                                   .XA.         
         LA    R1,DEVPARMS                                         .XA.         
         LA    R14,DEVWORK                                         .XA.         
         ST    R14,0(,R1)                                          .XA.         
         XC    0(100,R14),0(R14)                                   .XA.         
         LA    R14,DEVCLASS                                        .XA.         
         ST    R14,4(,R1)                                          .XA.         
         MVI   0(R14),X'20'        UCB3DACC (DASD UCB'S)           .XA.         
         LA    R14,DEVUCBAD                                        .XA.         
         ST    R14,8(,R1)                                          .XA.         
         OI    8(R1),X'80'                                         .XA.         
UCBLOOPX LA    R1,DEVPARMS                                         .XA.         
         L     R14,16              CVTPTR                          .XA.         
         L     R15,X'434'(,R14)    CVTUCBSC V(IOSVSUCB)            .XA.         
         BALR  R14,R15             CALL IOSVSUCB                   .XA.         
         LTR   R15,R15                                             .XA.         
         BNZ   FAILUCB                                             .XA.         
         L     R1,DEVUCBAD                                         .XA.         
         TM    3(R1),X'80'         ONLINE                          .XA.         
         BZ    UCBLOOPX                                            .XA.         
         CLC   28(6,R1),VOLSER     DOES VOLUME MATCH?              .XA.         
         BNE   UCBLOOPX            NO - BRANCH                     .XA.         
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         UCB FOUND                                                   *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
FOUNDUCB MVC   DEVICE(4),16(R1)    COPY UCBTYPE                                 
         NI    DEVICE+1,255-X'20'  SET OFF SHARED DASD BIT                      
         LA    R14,DEVICES                                                      
DEVLOOP  CLI   0(R14),0                                                         
         BE    DEVUNIT             UNKNOWN DEVICE TYPE                          
         CLC   DEVICE(4),0(R14)                                                 
         BE    DEVUNIT                                                          
         LA    R14,12(,R14)                                                     
         B     DEVLOOP                                                          
DEVUNIT  MVC   UNITNAME,4(R14)                                                  
         MVC   ALTCYL,10(R14)                                                   
         MVC   CUU,13(R1)                                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         OBTAIN THE FORMAT-4 DSCB FROM THE VTOC                      *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R1,CAMLST                                                        
         MVC   0(16,R1),OBTCAM4                                                 
         LA    R15,F4KEY                                                        
         MVI   0(R15),X'04'                                                     
         MVC   1(43,R15),0(R15)                                                 
         ST    R15,4(,R1)                                                       
         LA    R0,VOLSER                                                        
         ST    R0,8(,R1)                                                        
         LA    R0,F4DSCB                                                        
         ST    R0,12(,R1)                                                       
         OBTAIN (1)                                                             
         LTR   R15,R15             WAS FORMAT 4 READ OK                         
         BNZ   FAILUCB             NO, GO FIND OUT WHY                          
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         INITIAL VALUES FOR READING EXTENTS                          *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R0,EXTENCE                                                       
         ST    R0,EXTPTR                                                        
         SR    R0,R0                                                            
         ST    R0,EXTCNT                                                        
         ST    R0,BINCALLS                                                      
         ST    R0,BINFIVES                                                      
         XC    LRGEXT,LRGEXT                                                    
         MVI   ORDER,C'L'          ORDERED BY LOCATION                          
         MVC   MY99TXDD+6(8),=CL8' '                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         CHECK FOR INDEXED VTOC                                      *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R7,F4DSCB                                                        
         USING F4DSECT,R7                                                       
         CLC   UNITNAME(4),=C'3340'                                             
         BNE   NOT3340                                                          
         CLC   DS4DEVSZ(2),=H'698' IF 70MB 3340                                 
         BNE   NOT3340                THEN                                      
         MVC   ALTCYL,=H'2'           2 ALT CYL                                 
NOT3340  EQU   *                                                                
         LH    R1,DS4DEVSZ                                                      
         SH    R1,ALTCYL                                                        
         STH   R1,CYLVOL                                                        
         MVC   TRKCYL,DS4DEVSZ+2                                                
         MVC   DSRECF4,DS4DSREC                                                 
         MVC   VTOCE,DS4VTOCE                                                   
         MVC   VTOCI,DS4VTOCI                                                   
         AIF   ('&MVS38J' EQ 'YES').M38JXT0   YES, Enclude source       *MVS38J
.*                                            Else Include source       *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Exclude for MVS 3.8J OS  <==       * *MVS38J 
*********************************************************************** *MVS38J 
         TM    DS4VTOCI,1                                                       
         BO    INDEXED                                                          
.M38JXT0 ANOP                      Terminating conditional assembly tag *MVS38J
         SPACE                                                                  
         MVC   CCHHR(4),DS4VTOCE+2                                              
         MVI   CCHHR+4,2           FMT5'S START WITH RECORD 2                   
         DROP  R7                                                               
         SR    R3,R3                                                            
         SR    R4,R4                                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         NOT INDEXED - READ FORMAT 5 DSCB'S                          *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
F5OLOOP  LA    R1,CAMLST                                                        
         MVC   0(16,R1),OBTCAM5                                                 
         LA    R15,CCHHR                                                        
         ST    R15,4(,R1)                                                       
         LA    R0,VOLSER                                                        
         ST    R0,8(,R1)                                                        
         LA    R0,F5DSCB                                                        
         ST    R0,12(,R1)                                                       
         OBTAIN (1)                                                             
         LTR   R15,R15             WAS FORMAT 5 READ OK                         
         BNZ   FAILUCB             NO, GO FIND OUT WHY                          
         SPACE                                                                  
         LA    R0,1                                                             
         A     R0,BINFIVES                                                      
         ST    R0,BINFIVES                                                      
         SPACE                                                                  
         LA    R7,F5DSCB                                                        
         USING F5DSECT,R7                                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         COPY EXTENTS TO AREA CONTAINING ALL EXTENTS                 *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         MVC   DS5FMTID(90),DS5FMTID+1  ALL 26 IN A ROW                         
         LA    R14,DS5AVEXT        POINT TO FIRST OF 26                         
         SR    R1,R1               COUNTER                                      
         L     R15,EXTPTR                                                       
         LA    R0,26               NUMBER OF EXTENTS IN RECORD                  
         MVI   DOUBLE+2,0                                                       
F5ILOOP  CLC   0(5,R14),=X'0000000000' NULL ENTRY                               
         BE    F5INXT              YES, IGNORE                                  
         MVC   0(5,R15),0(R14)                                                  
         MVC   DOUBLE(2),2(R14)    CYLS                                         
         AH    R3,DOUBLE                                                        
         MVC   DOUBLE+3(1),4(R14)  TRKS                                         
         AH    R4,DOUBLE+2                                                      
         CLC   LRGEXT,2(R14)                                                    
         BNL   *+10                                                             
         MVC   LRGEXT,2(R14)                                                    
         LA    R15,5(,R15)                                                      
         LA    R1,1(,R1)           COUNT                                        
F5INXT   LA    R14,5(,R14)                                                      
         BCT   R0,F5ILOOP                                                       
F5IDONE  ST    R15,EXTPTR                                                       
         A     R1,EXTCNT           ADD COUNT IN R1                              
         ST    R1,EXTCNT            TO TOTAL COUNT                              
F5IMORE  MVC   CCHHR,DS5PTRDS      POINT TO NEXT FORMAT5                        
         CLC   CCHHR,=X'0000000000' IS THERE ANOTHER?                           
         BNE   F5OLOOP             YES, GO READ IT                              
         DROP  R7                  F5DSECT                                      
         MVC   VOLUME,VOLSER                                                    
         ST    R3,BINCYL                                                        
         ST    R4,BINTRK                                                        
         B     HAVEXT                                                           
         AIF   ('&MVS38J' EQ 'YES').M38JXT1   YES, Exclude source       *MVS38J
.*                                            Else Include source       *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Exclude for MVS 3.8J OS  <==       * *MVS38J 
*********************************************************************** *MVS38J 
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         ALLOCATE THE VOLUME                                         *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
INDEXED  LA    R1,MY99RBP                                                       
         LA    R15,MY99RB                                                       
         ST    R15,0(,R1)                                                       
         OI    0(R1),X'80'                                                      
         XC    0(20,R15),0(R15)                                                 
         MVC   0(3,R15),=X'140140'                                              
         LA    R14,MY99TUPL                                                     
         ST    R14,8(,R15)                                                      
*                                                                               
         LA    R15,MY99TXDD                                                     
         ST    R15,0(,R14)                                                      
         MVC   0(14,R15),=X'0055000100084040404040404040' DALRTDDN              
*                                                                               
         LA    R15,MY99TXUN                                                     
         ST    R15,4(,R14)                                                      
         MVC   0(06,R15),=X'001500010003'                 DALUNIT               
         MVC   6(3,R15),CUU                                                     
         SPACE                                                                  
         LA    R15,MY99TXVL                                                     
         ST    R15,8(,R14)                                                      
         MVC   0(06,R15),=X'001000010006'                 DALVLSER              
         MVC   6(6,R15),VOLSER                                                  
         SPACE                                                                  
         LA    R15,MY99TXST                                                     
         ST    R15,12(,R14)                                                     
         MVC   0(07,R15),=X'00040001000108'               DALSTATS              
         SPACE                                                                  
         LA    R15,MY99TXFC                                                     
         ST    R15,16(,R14)                                                     
         MVC   0(04,R15),=X'001C0000'                     DALCLOSE              
         OI    16(R14),X'80'                                                    
         SPACE                                                                  
         LA    R1,MY99RBP                                                       
         SVC   99                                                               
         SPACE                                                                  
         LTR   R15,R15                                                          
         BNZ   FAILUCB                                                          
         OI    SWA,SWA20           ALLOCATED                                    
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         OPEN THE VTOC, TO BUILD A DEB                               *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R7,DYNDCBW                                                       
         MVC   0(DYNDCBL,R7),DYNDCBM                                            
         MVC   DDNAM(8,R7),MY99TXDD+6                                           
         LA    R1,DYNJFCB                                                       
         LA    R15,DYNEXL                                                       
         ST    R1,0(,R15)                                                       
         MVI   0(R15),X'87'                                                     
         STCM  R15,7,EXLST+1(R7)                                                
         MVI   OPEN,X'80'                                                       
         SPACE                                                                  
         RDJFCB ((R7)),MF=(E,OPEN)                                              
         SPACE                                                                  
         LTR   R15,R15                                                          
         BNZ   FAILUCB                                                          
         MVI   DYNJFCB,X'04'                                                    
         MVC   DYNJFCB+1(43),DYNJFCB                                            
         OI    DYNJFCB+52,X'08'    DO NOT WRITE BACK DURING OPEN                
         MVI   OPEN,X'80'                                                       
         OPEN  ((R7),INPUT),TYPE=J,MF=(E,OPEN)                                  
         OI    SWA,SWA10           OPENED                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         ISSUE CVAFDSM TO GET NUMBER OF DSCBS AVAILABLE              *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         L     R7,DEBAD(,R7)                                                    
         MVC   CVAFDSM(CVAFDSML),CVAFDSMM                                       
         CVAFDSM ACCESS=MAPDATA,MAP=VTOC,COUNT=YES,CTAREA=CTAREA,      +        
               DEB=(R7),                                               +        
               MAPRCDS=NO,IOAREA=NOKEEP,BRANCH=NO,MF=(E,CVAFDSM)                
         LA    R7,DYNDCBW                                                       
         ST    R15,CVAFDSRC                                                     
         SR    R14,R14                                                          
         IC    R14,CVAFDSM+7                                                    
         ST    R14,CVAFDSST                                                     
         LTR   R15,R15                                                          
         BZ    OKCTAREA                                                         
         XC    CTAREA,CTAREA                                                    
OKCTAREA EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         SET UP EXTENT VARIABLES FOR FIRST CALL                      *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         XC    EXTENTS+1(2),EXTENTS+1                                           
         SR    R3,R3                                                            
         SR    R4,R4                                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         ISSUE CVAFDSM                                               *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
*             NOTE: THE INTEGRITY OF THE MAP RECORDS READ IS MAINTAINED         
*             ONLY IF THE VTOC IS ENQUEUED AND THE VOLUME IS RESERVED.          
*             THIS PROGRAM CANNOT DO THAT BECAUSE IT IS UNAUTHORIZED.           
         SPACE                                                                  
CVAFLOOP L     R7,DEBAD(,R7)                                                    
         MVC   CVAFDSM(CVAFDSML),CVAFDSMM                                       
         MVI   EXTENTS,255                                                      
         LA    R0,1                                                             
         A     R0,BINCALLS                                                      
         ST    R0,BINCALLS                                                      
         CVAFDSM ACCESS=MAPDATA,MAP=VOLUME,COUNT=NO,EXTENTS=EXTENTS,   +        
               DEB=(R7),                                               +        
               MAPRCDS=NO,IOAREA=NOKEEP,BRANCH=NO,MF=(E,CVAFDSM)                
         LA    R7,DYNDCBW                                                       
         ST    R15,CVAFRC                                                       
         SR    R14,R14                                                          
         IC    R14,7(,R1)          CVSTAT                                       
         ST    R14,BINSTAT         SAVE CVSTAT                                  
         LTR   R15,R15                                                          
         BZ    OKEXTEN                                                          
         CH    R15,=H'4'                                                        
         BNE   CVAFERR1                                                         
         CLI   7(R1),32                                                         
         BNE   CVAFERR1                                                         
OKEXTEN  EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         COPY EXTENTS TO AREA CONTAINING ALL EXTENTS                 *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R14,EXTENTS+1                                                    
         SR    R1,R1               COUNTER                                      
         L     R15,EXTPTR                                                       
         SR    R0,R0                                                            
         IC    R0,EXTENTS          NUMBER OF EXTENTS REQUESTED                  
         MVI   DOUBLE+2,0                                                       
EXTLOOP  CR    R1,R0               HAVE WE GOT THEM ALL                         
         BE    EXTDONE             YES, BRANCH                                  
         CLC   0(5,R14),=X'0000000000' END OF DATA                              
         BE    EXTEOD                                                           
         MVC   0(5,R15),0(R14)                                                  
         MVC   DOUBLE(2),2(R14)    CYLS                                         
         AH    R3,DOUBLE                                                        
         MVC   DOUBLE+3(1),4(R14)  TRKS                                         
         AH    R4,DOUBLE+2                                                      
         CLC   LRGEXT,2(R14)                                                    
         BNL   *+10                                                             
         MVC   LRGEXT,2(R14)                                                    
         LA    R15,5(,R15)                                                      
         LA    R1,1(,R1)                                                        
         LA    R14,5(,R14)                                                      
         B     EXTLOOP                                                          
EXTEOD   ST    R15,EXTPTR                                                       
         A     R1,EXTCNT                                                        
         ST    R1,EXTCNT                                                        
         CLI   CVAFRC+3,4                                                       
         BE    EXTGOT                                                           
         B     CVAFERR2            RC 0 BUT NULL EXTENT FOUND                   
EXTDONE  ST    R15,EXTPTR                                                       
         A     R1,EXTCNT                                                        
         ST    R1,EXTCNT                                                        
         CLI   CVAFRC+3,0                                                       
         BNE   CVAFERR3            RC 4-32 BUT NO NULL EXTENT                   
EXTMORE  SH    R15,=H'5'           POINT TO LAST EXTENT PROCESSED               
         MVC   EXTENTS+1(2),0(R15) SET BEGINNING RTA FOR NEXT REQUEST           
         B     CVAFLOOP                                                         
EXTGOT   ST    R3,BINCYL                                                        
         ST    R4,BINTRK                                                        
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         CLOSE AND UNALLOCATE                                        *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R8,DYNCLOSX                                                      
.M38JXT1 ANOP                      Terminating conditional assembly tag *MVS38J 
DYNCLOSE TM    SWA,SWA20           ALLOCATED                                    
         BZR   R8                  NO, SKIP CLOSE-AND-UNALLOCATE                
         MVI   CLOSE,X'80'                                                      
         CLOSE ((R7)),MF=(E,CLOSE)                                              
         NI    SWA,255-SWA20                                                    
         NI    SWA,255-SWA10                                                    
         BR    R8                                                               
DYNCLOSX EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         MAKE MORE DEFINED VARIABLES                                 *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
HAVEXT   TM    SWA,SWA80           BEEN HERE BEFORE?                            
         BO    DEFINED             YES, BYPASS                                  
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXV02)'                                         
         LA    R0,WRKNEXT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'6'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXOPT)'                                         
         LA    R0,WRKOPT                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'1'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXUNIT)'                                        
         LA    R0,WRKUNIT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'6'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXCYL)'                                         
         LA    R0,WRKCYL                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXTRK)'                                         
         LA    R0,WRKTRK                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXEXT)'                                         
         LA    R0,WRKEXT                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXLRGC)'                                        
         LA    R0,WRKLRGC                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXLRGT)'                                        
         LA    R0,WRKLRGT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXATOT)'                                        
         LA    R0,WRKATOT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXLTOT)'                                        
         LA    R0,WRKLTOT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXPCU)'                                         
         LA    R0,WRKPCTU                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXCPV)'                                         
         LA    R0,WRKCPV                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXTPC)'                                         
         LA    R0,WRKTPC                                                        
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXDSREC)'                                       
         LA    R0,WRKDSREC                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXDSROS)'                                       
         LA    R0,WRKDSROS                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXDSRIX)'                                       
         LA    R0,WRKDSRIX                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXNOTE)'                                        
         LA    R0,WRKNOTE                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'60'                                                   
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXDSMRC)'                                       
         LA    R0,WRKDSMRC                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXSTAT)'                                        
         LA    R0,WRKSTAT                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXDDNAM)'                                       
         LA    R0,WRKDDNAM                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'8'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXCALLS)'                                       
         LA    R0,WRKCALLS                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXFIVES)'                                       
         LA    R0,WRKFIVES                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'7'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXTRACS)'                                       
         LA    R0,WRKTRACS                                                      
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXVTOC1)'                                       
         LA    R0,WRKVTOCE+4                                                    
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'8'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(ULXVTOC2)'                                       
         LA    R0,WRKVTOCE+12                                                   
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'8'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         OI    SWA,SWA80                                                        
DEFINED  EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         MOVE DATA FROM MESSAGE AREA TO DEFINED FIELDS               *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         MVC   VOLUME,VOLSER                                                    
         MVC   WRKUNIT,UNITNAME                                                 
         MVC   WRKDDNAM,MY99TXDD+6                                              
         MVI   WRKNOTE,C' '                                                     
         MVC   WRKNOTE+1(L'WRKNOTE-1),WRKNOTE                                   
         SPACE                                                                  
         LH    R1,DSRECF4                                                       
         BAL   R8,LJ7                                                           
         MVC   WRKDSREC,WORK                                                    
         MVC   WRKDSROS,WORK                                                    
         MVC   WRKDSRIX,=CL7'N/A'                                               
         TM    VTOCI,1             INDEXED VTOC?                                
         BNO   GOTDSCBS            NO                                           
         L     R15,CVAFDSRC        GET RESULT OF CVAF REQUEST                   
         LTR   R15,R15             WAS CVAF SUCCESSFUL                          
         BZ    IXVTOC              YES, BRANCH                                  
         MVC   WRKDSRIX,=CL7'ERR'                                               
         B     GOTDSCBS            AND SHOW VALUE FROM FORMAT 4                 
IXVTOC   L     R1,CTAREA           YES, GET AVAILABLE DSCB'S                    
         BAL   R8,LJ7                                                           
         MVC   WRKDSREC,WORK                                                    
         MVC   WRKDSRIX,WORK                                                    
GOTDSCBS EQU   *                                                                
         SPACE                                                                  
         L     R1,BINTRK                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKTRK,WORK                                                      
         SPACE                                                                  
         L     R1,BINCYL                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKCYL,WORK                                                      
         SPACE                                                                  
         L     R1,EXTCNT                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKEXT,WORK                                                      
         SPACE                                                                  
         LH    R1,LRGEXT                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKLRGC,WORK                                                     
         SPACE                                                                  
         SR    R1,R1                                                            
         IC    R1,LRGEXT+2                                                      
         BAL   R8,LJ7                                                           
         MVC   WRKLRGT,WORK                                                     
         SPACE                                                                  
         L     R1,BINCYL                                                        
         MH    R1,TRKCYL                                                        
         A     R1,BINTRK                                                        
         ST    R1,TRKTOTA                                                       
         BAL   R8,LJ7                                                           
         MVC   WRKATOT,WORK                                                     
         SPACE                                                                  
         LH    R1,CYLVOL                                                        
         MH    R1,TRKCYL           COMPUTE TRACKS PER VOLUME                    
         LR    R15,R1              GET TRACKS PER VOLUME                        
         S     R15,TRKTOTA         MINUS TRKS AVAILABLE = TRKS USED             
         M     R14,=F'100'         TIMES 100                                    
         DR    R14,R1              COMPUTE PERCENTAGE USED                      
         LR    R1,R15                                                           
         BAL   R8,LJ7                                                           
         MVC   WRKPCTU,WORK                                                     
         SPACE                                                                  
         LH    R1,LRGEXT                                                        
         MH    R1,TRKCYL                                                        
         SR    R0,R0                                                            
         IC    R0,LRGEXT+2                                                      
         AR    R1,R0                                                            
         BAL   R8,LJ7                                                           
         MVC   WRKLTOT,WORK                                                     
         SPACE                                                                  
         L     R1,CVAFRC                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKDSMRC,WORK                                                    
         SPACE                                                                  
         L     R1,BINSTAT                                                       
         BAL   R8,LJ7                                                           
         MVC   WRKSTAT,WORK                                                     
         SPACE                                                                  
         LH    R1,CYLVOL                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKCPV,WORK                                                      
         SPACE                                                                  
         LH    R1,TRKCYL                                                        
         BAL   R8,LJ7                                                           
         MVC   WRKTPC,WORK                                                      
         SPACE                                                                  
         L     R1,BINCALLS                                                      
         BAL   R8,LJ7                                                           
         MVC   WRKCALLS,WORK                                                    
         SPACE                                                                  
         L     R1,BINFIVES                                                      
         BAL   R8,LJ7                                                           
         MVC   WRKFIVES,WORK                                                    
         SPACE                                                                  
         TM    VTOCI,1             INDEXED                                      
         BO    NONA                YES, LEAVE CVAF VALUES ALONE                 
         MVC   WRKDSMRC,=CL8'N/A'                                               
         MVC   WRKSTAT,=CL8'N/A'                                                
         MVC   WRKDDNAM,=CL8'N/A'                                               
NONA     EQU   *                                                                
         SPACE                                                                  
         LA    R1,VTOCE                                                         
         LA    R15,WRKVTOCE                                                     
         LA    R0,10                                                            
         BAL   R14,HEXCVT                                                       
         SPACE                                                                  
         MVC   DOUBLE(8),VTOCE+2                                                
         LH    R14,DOUBLE+2        HH                                           
         LH    R0,TRKCYL           TRACKS PER CYL                               
         LA    R1,1                                                             
COUNTEM  CLC   DOUBLE,DOUBLE+4                                                  
         BNL   COUNTED                                                          
         LA    R1,1(,R1)           COUNT                                        
         LA    R14,1(,R14)         ADD 1 TO HH                                  
         CR    R14,R0              IF BEYOND LAST                               
         BNE   NOTLAST                THEN                                      
         LH    R15,DOUBLE               ADD 1                                   
         AH    R15,=H'1'                  TO                                    
         STH   R15,DOUBLE                   CC                                  
         SR    R14,R14                  ZERO HH                                 
NOTLAST  STH   R14,DOUBLE+2                                                     
         B     COUNTEM                                                          
COUNTED  LR    R14,R1                                                           
         BAL   R8,LJ7                                                           
         MVC   WRKTRACS,WORK                                                    
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         DISPLAY PANEL P02 AND WAIT FOR ENTER                        *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         MVC   WRKNEXT,=CL6' '                                                  
PAN02    MVI   WRKOPT,C' '                                                      
         LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'DISPLAY'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,PANEL                                                         
         MVC   PANEL,=CL8'ULXP02'                                               
         MVC   PANEL(3),PFX                                                     
         ST    R0,4(,R1)                                                        
         OI    4(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
ERRX02   CLC   WRKNEXT,=CL6' '     ANOTHER VOLUME ENTERED?                      
         BE    ERRX02A             NO                                           
         MVC   VOLSER,WRKNEXT                                                   
         B     REREAD                                                           
ERRX02A  EQU   *                                                                
         CH    R15,=H'8'           PF3                                          
*        BE    PAN01               YES, BACK TO PANEL 1                         
         BE    EXIT0               YES, END APPLICATION                         
         CLI   WRKOPT,C'L'         LIST REQUESTED                               
         BE    LISTEXT             YES                                          
         CLI   WRKOPT,C'S'         LIST REQUESTED                               
         BE    LISTEXT             YES                                          
         B     PAN02               REPEAT PANEL 2                               
LISTEXT  L     R6,EXTCNT       GET NUMBER OF EXTENTS                            
         LTR   R6,R6           ARE THERE ANY EXTENTS                            
         BZ    ERRZEX          DONE IF NOT                                      
         C     R6,=F'1'            ONLY ONE EXTENT?                             
         BE    SORTED              YES, BYPASS SORT                             
         CLI   WRKOPT,C'L'     REQUEST SORT BY LOCATION?                        
         BE    SORTL           YES, BRANCH                                      
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         SORT EXTENT TABLE IN DESCENDING ORDER BY SIZE               *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         CLI   ORDER,C'S'          ALREADY IN SIZE ORDER                        
         BE    SORTED              YES, BRANCH                                  
         MVI   ORDER,C'S'                                                       
         LA    R7,EXTENCE                                                       
         BCTR  R6,0                NUMBER OF EXTENTS MINUS 1                    
         MH    R6,=H'5'            SIZE OF TABLE, MINUS 5 BYTES                 
         LA    R8,EXTENCE(R6)      POINT TO LAST ENTRY IN TABLE                 
SORTO    SR    R0,R0                                                            
         LA    R7,EXTENCE                                                       
SORTI    CLC   2(3,R7),7(R7)                                                    
         BNL   SORT2                                                            
         XC    0(5,R7),5(R7)       SWAP                                         
         XC    5(5,R7),0(R7)        SWAP                                        
         XC    0(5,R7),5(R7)         SWAP                                       
         BCTR  R0,0                A SWAP TOOK PLACE                            
SORT2    LA    R7,5(,R7)           NEXT PAIR                                    
         CR    R7,R8               IS THIS THE LAST ONE?                        
         BL    SORTI               NO, LOOP                                     
         LTR   R0,R0               ANY SWAPS DURING THAT PASS?                  
         BZ    SORTED              NO, WE ARE DONE                              
         B     SORTO                                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         SORT EXTENT TABLE IN ASCENDING ORDER BY LOCATION            *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
SORTL    CLI   ORDER,C'L'          ALREADY IN LOCATION ORDER                    
         BE    SORTED              YES, BRANCH                                  
         MVI   ORDER,C'L'                                                       
         LA    R7,EXTENCE                                                       
         BCTR  R6,0                NUMBER OF EXTENTS MINUS 1                    
         MH    R6,=H'5'            SIZE OF TABLE, MINUS 5 BYTES                 
         LA    R8,EXTENCE(R6)      POINT TO LAST ENTRY IN TABLE                 
SORTLO   SR    R0,R0                                                            
         LA    R7,EXTENCE                                                       
SORTLI   CLC   0(2,R7),5(R7)                                                    
         BNH   SORTL2                                                           
         XC    0(5,R7),5(R7)       SWAP                                         
         XC    5(5,R7),0(R7)        SWAP                                        
         XC    0(5,R7),5(R7)         SWAP                                       
         BCTR  R0,0                A SWAP TOOK PLACE                            
SORTL2   LA    R7,5(,R7)           NEXT PAIR                                    
         CR    R7,R8               IS THIS THE LAST ONE?                        
         BL    SORTLI              NO, LOOP                                     
         LTR   R0,R0               ANY SWAPS DURING THAT PASS?                  
         BZ    SORTED              NO, WE ARE DONE                              
         B     SORTLO                                                           
SORTED   EQU   *                                                                
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         CREATE EXTENT TABLE                                         *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         TM    SWA,SWA08           BEEN HERE BEFORE?                            
         BO    DEFINED2            YES, BYPASS                                  
         OI    SWA,SWA08                                                        
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBS)'   SCROLL VARIABLE                          
         LA    R0,TBS                                                           
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'4'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBSEQ)'                                          
         LA    R0,TBSEQ+1                                                       
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'5'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBEXT)'                                          
         LA    R0,TBEXT                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'10'                                                   
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBCYL)'                                          
         LA    R0,TBCYL                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'5'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBTRA)'                                          
         LA    R0,TBTRA                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'3'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBTRK)'                                          
         LA    R0,TBTRK                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'5'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBBEG)'                                          
         LA    R0,TBBEG                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'8'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
         MVC   VDEFNAME,=CL10'(TBEND)'                                          
         LA    R0,TBEND                                                         
         MVC   VDEFFMT,=CL8'CHAR'                                               
         MVC   VDEFLEN,=F'8'                                                    
         BAL   R8,VDEFINE                                                       
         SPACE                                                                  
DEFINED2 EQU   *                                                                
         SPACE                                                                  
         LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'TBCREATE'                                           
         ST    R0,0(,R1)                                                        
         LA    R0,TABLNAME                                                      
         MVC   TABLNAME,=CL8'ULXT01'                                            
         ST    R0,4(,R1)                                                        
         LA    R0,KEYNAMES                                                      
         MVC   KEYNAMES,=CL10'(TBSEQ)'                                          
         ST    R0,8(,R1)                                                        
         LA    R0,VARNAMES                                                      
         MVC   VARNAMES,=CL37'(TBEXT TBCYL TBTRA TBTRK TBBEG TBEND)'            
         ST    R0,12(,R1)                                                       
         LA    R0,NOWRITE                                                       
         MVC   NOWRITE,=CL8'NOWRITE'                                            
         ST    R0,16(,R1)                                                       
         LA    R0,REPLACE                                                       
         MVC   REPLACE,=CL8'REPLACE'                                            
         ST    R0,20(,R1)                                                       
         OI    20(R1),X'80'                                                     
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
         CH    R15,=H'4'                                                        
         BH    ERRTC                                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         FORMAT DATA FOR A ROW OF THE TABLE                          *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
* LOOP TO FORMAT EXTENTS FOR ISPF TABLE                                         
         L     R7,EXTCNT                                                        
         LA    R6,EXTENCE                                                       
         SR    R5,R5                                                            
NXTROW   A     R5,=F'1'                                                         
         CVD   R5,DOUBLE                                                        
         MVC   TBSEQ,=X'402020202120'                                           
         ED    TBSEQ,DOUBLE+5                                                   
         SPACE                                                                  
         LR    R1,R6                                                            
         LA    R0,5                                                             
         LA    R15,TBEXT                                                        
         BAL   R14,HEXCVT                                                       
         SPACE                                                                  
         MVC   DOUBLE(2),2(R6)                                                  
         LH    R1,DOUBLE                                                        
         BAL   R8,RJ7BZ                                                         
         MVC   TBCYL,WORK+3                                                     
         SPACE                                                                  
         SR    R1,R1                                                            
         IC    R1,4(,R6)                                                        
         BAL   R8,RJ7BZ                                                         
         MVC   TBTRA,WORK+5                                                     
         SPACE                                                                  
         MVC   DOUBLE(2),2(R6)                                                  
         LH    R1,DOUBLE                                                        
         MH    R1,TRKCYL                                                        
         SR    R0,R0                                                            
         IC    R0,4(,R6)                                                        
         AR    R1,R0                                                            
         ST    R1,BINTK                                                         
         BAL   R8,RJ7BZ                                                         
         MVC   TBTRK,WORK+3                                                     
         SPACE                                                                  
         XC    DOUBLE(2),DOUBLE                                                 
         MVC   DOUBLE+2(2),0(R6)                                                
         SR    R0,R0                                                            
         L     R1,DOUBLE                                                        
         LH    R15,TRKCYL                                                       
         DR    R0,R15                                                           
         STH   R1,BINBEG                                                        
         STH   R0,BINBEG+2                                                      
         SPACE                                                                  
         LA    R1,BINBEG                                                        
         LA    R0,4                                                             
         LA    R15,TBBEG                                                        
         BAL   R14,HEXCVT                                                       
         SPACE                                                                  
         XC    DOUBLE(2),DOUBLE                                                 
         MVC   DOUBLE+2(2),0(R6)                                                
         SR    R0,R0                                                            
         L     R1,DOUBLE                                                        
         A     R1,BINTK                                                         
         BCTR  R1,0                                                             
         LH    R15,TRKCYL                                                       
         DR    R0,R15                                                           
         STH   R1,BINEND                                                        
         STH   R0,BINEND+2                                                      
         SPACE                                                                  
         LA    R1,BINEND                                                        
         LA    R0,4                                                             
         LA    R15,TBEND                                                        
         BAL   R14,HEXCVT                                                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         FILL IN A ROW OF THE TABLE                                            
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'TBADD'                                              
         ST    R0,0(,R1)                                                        
         LA    R0,TABLNAME                                                      
         MVC   TABLNAME,=CL8'ULXT01'                                            
         ST    R0,4(,R1)                                                        
         OI    4(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
         CH    R15,=H'4'                                                        
         BH    ERRTA                                                            
         SPACE                                                                  
         LA    R6,5(,R6)                                                        
         BCT   R7,NXTROW       REPEAT IF ANY MORE EXTENTS                       
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         POINT CRP (CURRENT ROW POINTER) TO TOP                      *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
         LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'TBTOP'                                              
         ST    R0,0(,R1)                                                        
         LA    R0,TABLNAME                                                      
         ST    R0,4(,R1)                                                        
         OI    4(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         DISPLAY PANEL P03 AND WAIT FOR END                          *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
PAN03    LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'TBDISPL'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,TABLNAME                                                      
         ST    R0,4(,R1)                                                        
         LA    R0,PANEL                                                         
         MVC   PANEL,=CL8'ULXP03'                                               
         MVC   PANEL(3),PFX                                                     
         ST    R0,8(,R1)                                                        
         OI    8(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         SPACE                                                                  
         LTR   R15,R15                                                          
         BZ    PAN03                                                            
         B     PAN02                                                            
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         SUBROUTINES                                                           
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
LJUST    CLI   WORK,C' '                                                        
         BNER  R8                                                               
         MVC   WORK(7),WORK+1                                                   
         MVI   WORK+7,C' '                                                      
         B     LJUST                                                            
         SPACE                                                                  
LJ7      CVD   R1,DOUBLE                                                        
         OI    DOUBLE+7,X'0F'                                                   
         UNPK  WORK(7),DOUBLE+4(4)                                              
         LA    R0,6                                                             
LJ7B     CLI   WORK,C'0'                                                        
         BNER  R8                                                               
         MVC   WORK(6),WORK+1                                                   
         MVI   WORK+6,C' '                                                      
         BCT   R0,LJ7B                                                          
         BR    R8                                                               
         SPACE                                                                  
RJ7      CVD   R1,DOUBLE                                                        
         MVC   WORK(8),=X'4020202020202120'                                     
         ED    WORK(8),DOUBLE+4                                                 
         BR    R8                                                               
         SPACE                                                                  
RJ7BZ    CVD   R1,DOUBLE                                                        
         MVC   WORK(8),=X'4020202020202020'                                     
         ED    WORK(8),DOUBLE+4                                                 
         BR    R8                                                               
         SPACE                                                                  
HEXCVT   MVC   1(1,R15),0(R1)      MOVE BYTE                                    
         UNPK  0(3,R15),1(2,R15)   UNPACK                                       
         TR    0(2,R15),HEXTAB-240                                              
         LA    R15,2(,R15)         INCREMENT OUTPUT PTR                         
         LA    R1,1(,R1)           INCREMENT INPUT PTR                          
         BCT   R0,HEXCVT           DECREMENT LENGTH, THEN LOOP                  
         MVI   0(R15),C' '         BLANK THE TRAILING BYTE                      
         BR    R14                 RETURN TO CALLER                             
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         VDEFINE SERVICE                                                       
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
VDEFINE  LA    R1,PARAMS                                                        
         ST    R0,8(,R1)           STORE ADDRESS OF FIELD                       
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'VDEFINE'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,VDEFNAME                                                      
         ST    R0,4(,R1)                                                        
         AIF   ('&ISPFW' EQ 'YES').ISPFI01    YES, Include source       *MVS38J
         AGO   .ISPFX01                       Else Exclude source       *MVS38J
.ISPFI01 ANOP                                 Conditional assembly tag  *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Include for ISPF 2.x     <==       * *MVS38J 
*********************************************************************** *MVS38J 
*********************************************************************** *MVS38J 
*                                                                     * *MVS38J 
*        Specific logic for ISPF 2.x (product from Wally Mclaughlin)  * *MVS38J 
*                                                                     * *MVS38J 
*        For VDEFINE, left and right parentheses are removed and      * *MVS38J 
*        content is left justified for field VDEFNAME.                * *MVS38J 
*                                                                     * *MVS38J 
*               0........1                                            * *MVS38J 
*        byte   1234567890                                            * *MVS38J 
*        e.g.  "(ULXOPT)  " is tranformed to "ULXOPT    "             * *MVS38J 
*                                                                     * *MVS38J 
*********************************************************************** *MVS38J 
         CLI   VDEFNAME,C'('       VDEFNAME start with "(" in byte 1 ?  *MVS38J
         BNE   VDEFCONT            No, assume no parens, done!          *MVS38J
*                                  Yes, drop it by shifting content     *MVS38J
*                                    left by 1 byte                     *MVS38J
         MVC   VDEFNAME(L'VDEFNAME-1),VDEFNAME+1                        *MVS38J
         LA    R14,L'VDEFNAME-1    Length  of VDEFNAME - loop control   *MVS38J
         LA    R15,VDEFNAME+1      Address of VDEFNAME at byte 2        *MVS38J
VDEFLOOP EQU   *                                                        *MVS38J
         CLI   0(R15),C')'         Terminating ")" in VDEFNAME ?        *MVS38J
         BE    VDEFTPF             Yes, blank out paren and remaining   *MVS38J
         LA    R15,1(R15)          No, point to next byte in VDEFNAME   *MVS38J
         BCT   R14,VDEFLOOP        Check again...                       *MVS38J
         B     VDEFCONT            Done!                                *MVS38J
VDEFTPF  EQU   *                                                        *MVS38J
         MVI   0(R15),C' '         Blank out                            *MVS38J
         LA    R15,1(R15)          Point to next byte in VDEFNAME       *MVS38J
         BCT   R14,VDEFTPF         Finish up loop...                    *MVS38J
VDEFCONT EQU   *                                                        *MVS38J
.ISPFX01 ANOP                      Terminating conditional assembly tag *MVS38J
         LA    R0,VDEFFMT                                                       
         ST    R0,12(,R1)                                                       
         LA    R0,VDEFLEN                                                       
         ST    R0,16(,R1)                                                       
         OI    16(R1),X'80'                                                     
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         BR    R8                                                               
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         ERROR ROUTINES                                                        
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
FAILUCB  MVC   MSG,=CL8'ULXM011A' NOT MOUNTED                                   
         BAL   R8,DYNCLOSE                                                      
         B     ERRM01                                                           
         SPACE                                                                  
         AIF   ('&MVS38J' EQ 'YES').M38JXT2   YES, Exclude source       *MVS38J
.*                                            Else Include source       *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Exclude for MVS 3.8J OS  <==       * *MVS38J 
*********************************************************************** *MVS38J 
CVAFERR1 CLI   CVAFRC+3,4                                                       
         BNE   CVAFERR4                                                         
         CLI   BINSTAT+3,10                                                     
         BNE   CVAFERR4                                                         
         MVC   MSG,=CL8'ULXM012A' NONINDEXED VTOC                               
         BAL   R8,DYNCLOSE                                                      
         B     ERRM01                                                           
         SPACE                                                                  
CVAFERR2 MVC   MSG,=CL8'ULXM012B' ZERO ENTRY BUT RC WAS ZERO                    
         BAL   R8,DYNCLOSE                                                      
         B     ERRM01                                                           
         SPACE                                                                  
CVAFERR3 MVC   MSG,=CL8'ULXM012C' END OF DATA RC BUT NO ZERO ENTRY              
         BAL   R8,DYNCLOSE                                                      
         B     ERRM01                                                           
         SPACE                                                                  
CVAFERR4 MVC   MSG,=CL8'ULXM012D' UNEXPECTED RC FROM CVAFDSM                    
         BAL   R8,DYNCLOSE                                                      
         B     ERRM01                                                           
         SPACE                                                                  
.M38JXT2 ANOP                      Terminating conditional assembly tag *MVS38J
ERRZEX   MVC   MSG,=CL8'ULXM011C' NO EXTENTS                                    
         B     ERRM01                                                           
         SPACE                                                                  
ERRTC    MVC   MSG,=CL8'ULXM011D' TBCREATE ERROR                                
         B     ERRM01                                                           
         SPACE                                                                  
ERRTA    MVC   MSG,=CL8'ULXM011E' TBADD ERROR                                   
         B     ERRM01                                                           
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         RE-DISPLAY LAST PANEL WITH MESSAGE                          *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
ERRM01   LA    R1,PARAMS                                                        
         LA    R0,SERVICE                                                       
         MVC   SERVICE,=CL8'DISPLAY'                                            
         ST    R0,0(,R1)                                                        
         LA    R0,PANEL                                                         
         ST    R0,4(,R1)                                                        
         LA    R0,MSG                                                           
         MVC   MSG(3),PFX                                                       
         ST    R0,8(,R1)                                                        
         OI    8(R1),X'80'                                                      
         L     R15,ISPEXEC                                                      
         BALR  R14,R15                                                          
         CLI   PANEL+5,C'1'                                                     
         BE    ERRX01                                                           
         B     ERRX02                                                           
         SPACE                                                                  
***********************************************************************         
*                                                                     *         
*         RETURN TO CALLER                                            *         
*                                                                     *         
***********************************************************************         
         SPACE                                                                  
EXIT0    SR    R15,R15             RETURN CODE ZERO                             
         B     EXIT                                                             
EXIT12   LA    R15,12              RETURN CODE 12                               
EXIT     LR    R2,R15              SAVE RETURN CODE                             
         L     R0,ISPEXEC          GET ENTRY POINT OF ISPLINK                   
         LTR   R0,R0               WAS IT LOADED                                
         BZ    NODEL               NO, BYPASS DELETE                            
         DELETE EP=ISPLINK                                                      
         XC    ISPEXEC,ISPEXEC                                                  
NODEL    EQU   *                                                                
         LR    R1,R13              POINT R1 TO AREA TO BE FREED                 
         L     R0,@SIZE            SUBPOOL AND LENGTH                           
         L     R13,4(,R13)         RESTORE PREVIOUS SAVEAREA                    
         FREEMAIN R,A=(1),LV=(0)                                                
         LR    R15,R2                                                           
         LM    0,12,20(R13)        RESTORE REGISTERS                            
         L     14,12(,R13)         LOAD RETURN ADDRESS                          
         BR    14                  RETURN                                       
         SPACE                                                                  
         AGO   .ESTAE2                                                          
         SPACE                                                                  
************************************************************                    
*                                                          *                    
*         ESTAE EXIT                                       *                    
*                                                          *                    
************************************************************                    
         SPACE                                                                  
ESTAEX   DC    0H'0'                                                            
         USING *,R15                                                            
         CH    R0,ESTAE12                                                       
         BNE   ESTASDWA                                                         
         SPACE                                                                  
*              REG 0 IS 12                                                      
*              STORAGE NOT AVAILABLE FOR SDWA                                   
*              REG  1  -  CONTAINS ABEND COMPLETION CODE                        
*              REG  2  -  ADDRESS OF PARAM LIST FROM ESTAE MACRO                
*              REG 14  -  RETURN ADDRESS                                        
*              REG 15  -  ENTRY ADDRESS                                         
*              REGS 3-13  UNPREDICTABLE                                         
         SPACE                                                                  
         STM   14,12,ESTAEWSV+12-@DATA(R2)                                      
         LR    R9,R2               RESTORE R9                                   
         ST    R1,ESTAEWCC                                                      
         MVI   ESTAEWSW,C'N'                                                    
         B     ESTAEXC                                                          
ESTAE12  DC    H'12'                                                            
         SPACE                                                                  
ESTASDWA EQU   *                                                                
         SPACE                                                                  
*              REG  1  -  ADDRESS OF SDWA                                       
*              REG 13  -  ADDRESS OF 72 BYTE REGISTER SAVE AREA                 
*              REG 14  -  RETURN ADDRESS                                        
*              REG 15  -  ENTRY ADDRESS                                         
*              REGS 2-12  UNPREDICTABLE                                         
         SPACE                                                                  
         STM   14,12,12(R13)                                                    
         L     R9,0(,R1)           RESTORE R9                                   
         MVC   ESTAEWCC(4),4(R1)   SAVE ABEND CODE FROM SDWA                    
         MVC   ESTAEWPS(8),8(R1)   SAVE PSW FROM SDWA                           
         MVC   ESTAEWSV+12(60),12(R13)                                          
         MVI   ESTAEWSW,C'S'                                                    
         ST    R1,ESTAEWWA         SAVE SDWA ADDRESS                            
         SPACE                                                                  
*              COMMON TO EITHER TYPE OF ENTRY.                                  
*              (AS LONG AS YOU DONT REFER TO SDWA)                              
         SPACE                                                                  
         MVC   MESSAGE(38),=C'ABEND XXXXXXXX BASE XXXXXX PSW XXXXXX '           
         LA    R1,ESTAEWCC                                                      
         LA    R15,MESSAGE+6                                                    
         LA    R0,4                                                             
         BAL   R14,HEXCVT                                                       
         LA    R1,@BASES+1                                                      
         LA    R15,MESSAGE+20                                                   
         LA    R0,3                                                             
         BAL   R14,HEXCVT                                                       
         LA    R1,ESTAEWPS+5                                                    
         LA    R15,MESSAGE+31                                                   
         LA    R0,3                                                             
         BAL   R14,HEXCVT                                                       
         LA    R1,MESSAGE                                                       
         LA    R0,37                                                            
         SVC   93                                                               
         LA    R1,MESSAGE                                                       
         LA    R0,38                                                            
         O     R1,=A(X'80000000')                                               
         SVC   93                                                               
         SPACE                                                                  
ESTAEXC  EQU   *                                                                
         LM    R10,R11,@BASES      RESTORE BASE REGISTER                        
         DROP  R15                 DROP R15 ENTRY ADDRESS                       
         SPACE                                                                  
ESTAEX00 EQU   *                                                                
         CLI   ESTAEWSW,C'S'       SDWA PRESENT?                                
         BNE   ESTANOWA            NO - BRANCH                                  
         L     R1,ESTAEWWA         YES, RESTORE SDWA ADDRESS                    
         MVI   X'FC'(R1),0         SET SDWARCDE = 0                             
         LM    14,12,12(13)                                                     
         BR    R14                                                              
         SPACE                                                                  
ESTANOWA LM    14,12,ESTAEWSV+12                                                
         SLR   R15,R15             CONTINUE TERMINATION                         
         BR    R14                                                              
.ESTAE2  ANOP                                                                   
         DROP  R9,R10,R11          DROP ALL                                     
         SPACE                                                                  
************************************************************                    
*                                                          *                    
*        CONSTANTS                                         *                    
*                                                          *                    
************************************************************                    
         SPACE                                                                  
         LTORG                                                                  
         SPACE                                                                  
OBTCAM4  CAMLST SEARCH,2,3,4                                                    
         SPACE                                                                  
OBTCAM5  CAMLST SEEK,2,3,4                                                      
         SPACE                                                                  
         AIF   ('&MVS38J' EQ 'YES').M38JXT3   YES, Exclude source       *MVS38J
.*                                            Else Include source       *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Exclude for MVS 3.8J OS  <==       * *MVS38J 
*********************************************************************** *MVS38J 
CVAFDSMM CVAFDSM MF=L                                                           
CVAFDSML EQU   *-CVAFDSMM                                                       
         SPACE                                                                  
.M38JXT3 ANOP                      Terminating conditional assembly tag *MVS38J
*                UCBTYP      UNIT    ALTCYL                                     
DEVICES  DC    X'3010200F',C'3390  ',AL2(1)                                     
         DC    X'3010200E',C'3380  ',AL2(1)                                     
         DC    X'3010200C',C'3375  ',AL2(1)                                     
         DC    X'3050200B',C'3350  ',AL2(5)                                     
         DC    X'3050200D',C'3330-1',AL2(7)                                     
         DC    X'30502009',C'3330  ',AL2(7)                                     
         DC    X'30582009',C'3330V ',AL2(7) NOT SURE ABOUT ALT CYL              
         DC    X'3040200A',C'3340  ',AL2(1) 70MB VERSION HAS 2 ALT              
         DC    X'30502007',C'2305-2',AL2(1)                                     
         DC    X'00000000',C'?     ',AL2(1)                                     
         SPACE                                                                  
ESTAEM   ESTAE 1,MF=L                                                           
ESTAELL  EQU   *-ESTAEM                                                         
         SPACE                                                                  
NULL     DC    CL44'(NULL)'                                                     
HEXTAB   DC    C'0123456789ABCDEF' TRANSLATE TABLE                              
DYNDCBM  DCB   DDNAME=DYNAM,DSORG=PS,MACRF=(R),BLKSIZE=140                      
DYNDCBL  EQU   *-DYNDCBM                                                        
         DC    0D'0'                                                            
         SPACE                                                                  
DDNAM    EQU   40   DCB OFFSET                                                  
EXLST    EQU   36   DCB OFFSET                                                  
DEBAD    EQU   44   DCB OFFSET                                                  
         SPACE                                                                  
************************************************************                    
*                                                          *                    
*        DSECTS                                            *                    
*                                                          *                    
************************************************************                    
         SPACE                                                                  
@DATA    DSECT                                                                  
         DS    18F                 REGISTER SAVEAREA                            
WORK     DS    CL8                 WORK AREA                                    
DOUBLE   DS    D                   DOUBLEWORD WORK AREA                         
LINKAREA DS    2F                  LINK MACRO WORK AREA                         
FLAG     DS    F                                                                
@BASES   DS    3F                  BASE REGISTERS                               
ISPEXEC  DS    F                                                                
PARAMS   DS    8F                                                               
SERVICE  DS    CL8                                                              
PANEL    DS    CL8                                                              
MSG      DS    CL8                                                              
PFX      DS    CL3                                                              
VDEFNAME DS    CL10                                                             
VDEFFMT  DS    CL8                                                              
VDEFLEN  DS    F                                                                
ERRORS   DS    CL8                                                              
RETURN   DS    CL8                                                              
TABLNAME DS    CL8                                                              
KEYNAMES DS    CL10                                                             
VARNAMES DS    CL37                                                             
NOWRITE  DS    CL8                                                              
REPLACE  DS    CL8                                                              
TBS      DS    CL4                                                              
TBSEQ    DS    CL6                                                              
TBEXT    DS    CL10,X                                                           
TBCYL    DS    CL5                                                              
TBTRA    DS    CL3                                                              
TBTRK    DS    CL5                                                              
TBBEG    DS    CL8,X                                                            
TBEND    DS    CL8,X                                                            
CAMLST   DS    4F                                                               
CCHHR    DS    CL5                                                              
VOLUME   DS    CL6                                                              
VOLSER   DS    CL6                                                              
DEVICE   DS    CL4                                                              
UNITNAME DS    CL6                                                              
CUU      DS    CL3                                                              
S78MSG   DS    CL30                                                             
TRKTOTA  DS    F                                                                
TRKTOTV  DS    F                                                                
CYLVOL   DS    H                                                                
ALTCYL   DS    H                                                                
TRKCYL   DS    H                                                                
DSRECF4  DS    H                                                                
WRKNEXT  DS    CL7                                                              
WRKOPT   DS    CL1                                                              
SWA      DS    C                                                                
SWA80    EQU   X'80'                                                            
SWA40    EQU   X'40'                                                            
SWA20    EQU   X'20'                                                            
SWA10    EQU   X'10'                                                            
SWA08    EQU   X'08'                                                            
VTOCE    DS    CL10                                                             
VTOCI    DS    C                                                                
ORDER    DS    C                                                                
         DS    0F                                                               
F4KEY    DS    CL44                                                             
F4DSCB   DS    CL140                                                            
F5DSCB   DS    CL140                                                            
WRKUNIT  DS    CL6                                                              
WRKCYL   DS    CL4                                                              
WRKTRK   DS    CL4                                                              
WRKEXT   DS    CL4                                                              
WRKLRGC  DS    CL4                                                              
WRKLRGT  DS    CL4                                                              
WRKATOT  DS    CL7                                                              
WRKPCTU  DS    CL7                                                              
WRKLTOT  DS    CL7                                                              
WRKCPV   DS    CL7                                                              
WRKTPC   DS    CL7                                                              
WRKDSREC DS    CL7                                                              
WRKDSROS DS    CL7                                                              
WRKDSRIX DS    CL7                                                              
WRKDSMRC DS    CL7                                                              
WRKSTAT  DS    CL7                                                              
WRKDDNAM DS    CL8                                                              
WRKCALLS DS    CL7                                                              
WRKFIVES DS    CL7                                                              
WRKVTOCE DS    CL21                                                             
WRKTRACS DS    CL4                                                              
WRKNOTE  DS    CL60                                                             
CTAREA   DS    F                                                                
CVAFDSRC DS    F                                                                
CVAFDSST DS    F                                                                
CVAFRC   DS    F                                                                
BINCYL   DS    F                                                                
BINTRK   DS    F                                                                
BINLRGC  DS    F                                                                
BINLRGT  DS    F                                                                
BINSTAT  DS    F                                                                
BINCALLS DS    F                                                                
BINFIVES DS    F                                                                
BINTK    DS    F                                                                
BINBEG   DS    F                                                                
BINEND   DS    F                                                                
OPEN     DS    0F                                                               
CLOSE    DS    F                                                                
DYNDCBW  DS    0F,(DYNDCBL)X                                                    
DYNEXL   DS    F                                                                
         AIF   ('&MVS38J' EQ 'YES').M38JXT4   YES, Exclude source       *MVS38J
.*                                            Else Include source       *MVS38J
*********************************************************************** *MVS38J 
*        ==> Conditional Assembly: Exclude for MVS 3.8J OS  <==       * *MVS38J 
*********************************************************************** *MVS38J 
CVAFDSM  DS    0F,(CVAFDSML)X                                                   
.M38JXT4 ANOP                      Terminating conditional assembly tag *MVS38J
DYNJFCB  DS    0F,176X                                                          
DEVPARMS DS    3F                                                               
DEVCLASS DS    C                                                                
DEVUCBAD DS    F                                                                
DEVWORK  DS    25F                                                              
*                                                                               
MY99RBP  DS    F       REQUEST BLOCK POINTER                                    
MY99RB   DS    5F      REQUEST BLOCK                                            
MY99TUPL DS    5A      TEXT UNIT POINTERS                                       
MY99TXDD DS    3H,CL8  RETURN DDNAME                                            
MY99TXUN DS    3H,CL3  UNIT                                                     
MY99TXVL DS    3H,CL6  VOLSER                                                   
MY99TXST DS    3H,CL1  DISP=SHR                                                 
MY99TXFC DS    2H      FREE=CLOSE                                               
*                                                                               
ESTAEL   DS    0F,(ESTAELL)X                                                    
ESTAEWSV DS    18F                                                              
ESTAEWWA DS    F                                                                
ESTAEWCC DS    F                                                                
ESTAEWPS DS    2F                                                               
ESTAEWSW DS    C                                                                
MESSAGE  DS    CL38                                                             
         DS    0D                                                               
EXTCNT   DS    F                                                                
EXTPTR   DS    F                                                                
LRGEXT   DS    XL3,X                                                            
EXTENTS  DS    X,255CL5                                                         
EXTENCE  DS    2600XL5             100 FORMAT 5'S                               
         DS    0D                                                               
@DATAL   EQU   *-@DATA                                                          
         SPACE                                                                  
F4DSECT  DSECT                                                                  
*        IECSDSL1 4                                                             
DS4IDFMT DS    CL1                                                              
DS4HPCHR DS    XL5                                                              
DS4DSREC DS    XL2                                                              
DS4HCCHH DS    XL4                                                              
DS4NOATK DS    XL2                                                              
DS4VTOCI DS    XL1                                                              
DS4NOEXT DS    XL1                                                              
         DS    XL2                                                              
DS4DEVSZ DS    XL4                                                              
         DS    XL8                                                              
DS4DEVDT DS    XL1                                                              
DS4DEVDB DS    XL1                                                              
         DS    XL29                                                             
DS4VTOCE DS    XL10                                                             
         SPACE                                                                  
F5DSECT  DSECT                                                                  
*        IECSDSL1 5                                                             
DS5KEYID DS    XL4                                                              
DS5AVEXT DS    XL5     FIRST                                                    
DS5EXTAV DS    XL35    SEVEN MORE                                               
DS5FMTID DS    XL1                                                              
DS5MAVET DS    XL90    EIGHTEEN MORE                                            
DS5PTRDS DS    XL5                                                              
         SPACE                                                                  
R0       EQU   0                                                                
R1       EQU   1                                                                
R2       EQU   2                                                                
R3       EQU   3                                                                
R4       EQU   4                                                                
R5       EQU   5                                                                
R6       EQU   6                                                                
R7       EQU   7                                                                
R8       EQU   8                                                                
R9       EQU   9                                                                
R10      EQU   10                                                               
R11      EQU   11                                                               
R12      EQU   12                                                               
R13      EQU   13                                                               
R14      EQU   14                                                               
R15      EQU   15                                                               
         END                                                                    
@@
//LKED.SYSLMOD DD DSN=SYS2.CMDLIB(ULXL01),UNIT=,SPACE=,DISP=SHR
//LKED.SYSIN   DD DUMMY
