Is there any method by which we can restore the deleted members of a pds? I tried HRECOVER it didn't work. Also storage team doesn't take backup of the pds whic members have been deleted. Any help will be greatly appreciated.
if ... the dataset is a PDS not a PDSE
if ... the dataset has not been compressed
if ... Your support/Your organization rules let You install/installs itself freeware software
if ... You are lucky
the CBT tape ( the treasure chest of free software ) has some tools that let You resurrect dead PDS members
( the gas bubbles that are not pointed by directory entries )
if the above conditions are not met then You will have to retype everything
Joined: 09 Mar 2011 Posts: 7309 Location: Inside the Matrix
Try your storage people again. Maybe they have an "image copy" of the volume your PDS was on that might be some use if your problem is important enough.
Joined: 27 Oct 2009 Posts: 2481 Location: Netherlands, Amstelveen
Phil,
either case its sysout, i never did see compile listings go to datasets.
And sysout will also be kept for some (short/long ?)time.
Anyway looking at the TS's profile she/he should have known better
than to work without back-ups.
But then its always : it will never happen to me.
Joined: 31 Oct 2006 Posts: 1042 Location: Richmond, Virginia
Peter -
Granted, little chance my way would help, but a recent compile would still be on the screens, and the compile SYSOUT would be there.
So true though - BACKUP and save often.
We lost a small (25 cards) production control file once at a Fortune 500 company because it was used annually in the Fixed Assets system and it rolled off between refs. We recovered it from old printouts, but of course it should have been in Endevor.
Joined: 01 Sep 2006 Posts: 2546 Location: Silicon Valley
Quote:
if ... the dataset is a PDS not a PDSE
if ... the dataset has not been compressed
if ... Your support/Your organization rules let You install/installs itself freeware software
if ... You are lucky
If you are not so lucky about the installing freeware, you can use ADRDSSU utility:
Joined: 09 Mar 2011 Posts: 7309 Location: Inside the Matrix
To add to Pedro's then....
Look in appropriate manual for format of directory for your type of PDS. See if you can work out what it does to the directory entry for a deleted member (I know they are still there with PDS's, or they were when I did something with a directory a long time ago). Print out the directory, in hex (just specify the PDS name and it will give you the directory). Find your members in the directory. See how much has been splattered to mark it as deleted (manual I think tells you). You might be able to work out, physically, which active member yours are next to from the track address if it still exists for a deleted member (I can't remember). Locate something from the active member on Pedros print (you need the last, as any edits of those members will also be in the data). After that member, might be your stuff.
If you know something that is in the missing members, you can search for those in Pedro's output - maybe it even prints the track addres, I don't know how lucky you are. Remember to go for the last occurrence if you have to search, as any edits to your lost members since the last reorg will still be in the file as well.
In 1985, (I happen to have found it in an old listing) the track address is three bytes following the member name. This is followed by a one byte "indicator". If the "indicator" what is for deletes, you may be lucky. If you are lucky twice, not such a complicated task to recover.
If you try it, tell us if it works. If it does, maybe someone can "rexx" it for next time
for those who might have issues dealing with the CBT tape
here is a PDRESTORE that I have been using for many years
it will be posted in three messages ( there are issue with tagging lots of lines )
PART 1
Code:
TITLE 'P D R E S T - RESTORE DELETED MEMBERS FROM PDS'
***********************************************************************
* *
* MODULE NAME: PDREST *
* *
* TITLE: RESTORE DELETED MEMBERS FROM PDS *
* *
* COMPONENT: N/A *
* *
* ENVIRONMENT: TSO *
* *
* ATTRIBUTES: RENT REUS *
* AMODE 24 - RMODE 24 *
* PROBLEM STATE - KEY 8 (CALLERS STATE) *
* UNAUTHORIZED (CALLERS AUTHORIZATION) *
* *
* ENTRY POINT: PDREST *
* *
* INVOKATION: ATTACH AS A TSO COMMAND PROCESSOR *
* *
* PARAMETERS: *
* *
* PDREST INFILE('DDNAME') | INDATASET('DSNAME/PASSWORD') *
* OUTFILE('DDNAME') | OUTDATASET('DSNAME/PASSWORD') *
* DELETED | ALL *
* REPLACE | NOREPLACE *
* DEBUG | NODEBUG *
* *
* REQUIRED - INFILE|INDATASET, OUTFILE|OUTDATASET *
* *
* ABBREVIATIONS - *
* NOTE - IN ADDITION TO NORMAL TSO SHORT FORMS, THESE ARE ACCEPTED*
* INFILE IFILE *
* INDATASET IDS *
* OUTFILE OFILE *
* OUTDATASET ODS *
* *
* INFILE('DDNAME') *
* - SPECIFIES THE NAME OF THE DD STATEMENT THAT IDENTIFIES *
* THE INPUT DATASET TO PDREST. *
* 'DDNAME' - NAME OF THE DD STATEMENT THAT IDENTIFIES THE INPUT DATASE*
* TO PDREST. *
* INDATASET('DSNAME/PASSWORD') *
* - SPECIFIES THE NAME OF THE INPUT DATASET TO PDREST. *
* 'DSNAME' - NAME OF THE INPUT DATASET TO PDREST. *
* 'PASSWORD' *
* - PASSWORD OF THE INPUT DATASET TO PDREST. *
* REQUIRED - 'DSNAME' *
* OUTFILE('DDNAME') *
* - SPECIFIES THE NAME OF THE DD STATEMENT THAT IDENTIFIES *
* THE DATASET TO RECEIVE OUTPUT FROM PDREST. *
* 'DDNAME' - NAME OF THE DD STATEMENT THAT IDENTIFIES THE DATASET TO *
* RECEIVE OUTPUT FROM PDREST. *
* OUTDATASET('DSNAME/PASSWORD') *
* - SPECIFIES THE NAME OF THE DATASET TO RECEIVE OUTPUT FROM *
* PDREST. *
* 'DSNAME' - NAME OF THE DATASET TO RECEIVE OUTPUT FROM PDREST. *
* 'PASSWORD' *
* - PASSWORD OF THE DATASET TO RECEIVE OUTPUT FROM PDREST. *
* REQUIRED - 'DSNAME' *
* DELETED - SPECIFIES THAT ONLY DATA, THAT CANNOT BE REFERENCED VIA *
* THE DIRECTORY (E.G. DELETED MEMBERS) ARE TO BE COPIED. *
* MEMBERNAMES WILL BE GENERATED AND ASSIGNED TO THESE *
* NEW MEMBERS. *
* DEFAULT - DELETED *
* ALL - SPECIFIES THAT ALL DATA SHOULD BE COPIED, THAT IS BOTH *
* DATA THAT CAN BE REFERENCED VIA THE DIRECTORY AND 'DEAD' *
* MEMBERS. MEMBERNAMES WILL BE GENERATED AND ASSIGNED TO *
* THE 'DEAD' MEMBERS. OTHER MEMBERS WILL RETAIN THEIR OLD *
* MEMBERNAMES AND USERDATA. *
* DEFAULT - DELETED *
* REPLACE - SPECIFIES THAT PDREST IS TO REPLACE MEMBERS IN OUTPUT *
* DATASET WITH IDENTICAL MEMBERNAMES. *
* DEFAULT - NOREPLACE *
* NOREPLACE- SPECIFIES THAT PDREST WILL NOT COPY THOSE MEMBERS, THAT *
* EXIST IN OUTPUT DATASET. *
* DEFAULT - NOREPLACE *
* DEBUG - SPECIFIES THAT PDREST IS TO RUN IN DEBUG MODE. *
* THIS WILL RESULT IN A SUBSTANTIAL AMOUNT OF MESSAGES AND *
* SHOULD ONLY BE USED FOR TESTING. *
* DEFAULT - NODEBUG *
* NODEBUG - SPECIFIES THAT PDREST IS TO RUN IN NODEBUG MODE. *
* DEFAULT - NODEBUG *
* *
* INPUT: DDNAME SPECIFIED VIA IFILE/INFILE *
* DSNAME SPECIFIED VIA IDS/INDATASET *
* *
* OUTPUT: DDNAME SPECIFIED VIA OFILE/OUTFILE *
* DSNAME SPECIFIED VIA ODS/OUTDATASET *
* *
* EXIT NORMAL: AT PROGRAM END - VIA R14 *
* *
* RETURN CODE: 0 - FUNCTION COMPLETED OK *
* *
* EXIT ERROR: VIA ABEND SVC *
* *
* EXTERNAL REF: ROUTINES: IKJEFF18 IKJPARS IKJPUTL *
* TTR -> CCHHR CONV. ROUTINE *
* DATA AREAS: NONE *
* CONTROL BLOCKS: NONE *
* *
* ABEND CODES: USER 100 - INTERNAL ERROR IN PDREST *
* *
* MESSAGES: *
* *
* PDREST-01: WRITE (DATA/EOF): TTR=TTTTRR, CCHHR=CCCCHHHHRR, *
* LENGTH=LLLLL *
* PDREST-04: MEMBER HAS BEEN COPIED/REPLACED *
* PDREST-06: MEMBER HAS NOT BEEN COPIED, BECAUSE USERDATA CONTAINS *
* POINTERS *
* PDREST-07: MEMBER ALREADY EXISTS IN DIRECTORY AND IS NOT REPLACED *
* PDREST-08: NO SPACE LEFT IN DIRECTORY *
* PDREST-09: STOW I/O ERROR *
* PDREST-10: THE DCB IS OPENED INCORRECTLY FOR STOW *
* PDREST-11: INSUFFICIENT STORAGE FOR STOW GETMAIN *
* PDREST-12: UNSUCCESSFUL OPEN FOR DDNAME XXXXXXXX *
* PDREST-13: READ (DIR./DATA/EOF): TTR=TTTTRR, CCHHR=CCCCHHHHRR, *
* LENGTH=LLLLL *
* PDREST-14: EOF (DIR.), XXXX DIRBLKS, XXXXX MEMBERS *
* PDREST-16: MEMBER IS DEAD *
* PDREST-17: MEMBER NAME IS XXXXXXXX *
* PDREST-18: ALLOCATING NEW OUTPUT DATASET *
* PDREST-19: DDNAME XXXXXXXX IS MISSING *
* PDREST-20: INPUT DATASET IS NOT ON VOLUME XXXXXX *
* PDREST-21: INPUT DATASET IS NOT PARTITIONED *
* PDREST-22: OUTPUT DATASET IS NOT ON VOLUME XXXXXX *
* PDREST-23: OUTPUT DATASET IS NOT PARTITIONED *
* PDREST-24: INTERNAL ERROR IN PDREST *
* PDREST-25: NOT ENOUGH SPACE FOR IN STORAGE DIRECTORY. INCREASE *
* REGION SIZE *
* *
* FUNCTION: *
* RESTORE INFORMATION FROM A PARTITIONED DATASET *
* INACCESSIBLE BECAUSE OF MISSING DIRECTORY *
* INFORMATION. (E.G. A MEMBER, THAT HAS BEEN DELETED).*
* NOTE: FOLLOWING A COMPRESS OF THE PDS, PDREST WILL *
* NOT RESTORE DELETED MEMBERS. *
* SUBROUTINES: *
* *
* PDR0100 - GETMAIN AND INIT STORAGE *
* PDR0200 - BUILD CTL BLOCKS NEEDED FOR TSO SERVICE ROUT. *
* - CALL PARSE SERVICE ROUT. TO CHECK PARAMETERS *
* PDR0300 - ANALYZE PARMS: SET SWITCHES *
* PDR0400 - ALLOCATE INPUT DATASET VIA DYNALLOC *
* PDR0500 - CHECK ATTRIBUTES OF INPUT DATASET *
* - MUST BE DSORG=PO *
* - SAVE RECFM, LRECL, BLKSIZE AND LAST BLOCK PTR*
* PDR0600 - OPEN INPUT DATASET *
* PDR0700 - READ DIRECTORY FOR INPUT DATASET INTO STORAGE *
* PDR0800 - ALLOCATE OUTPUT DATASET VIA DYNALLOC *
* - IF NOT CATALOGED, CREATE A NEW ONE *
* PDR0900 - CHECK ATTRIBUTES OF OUTPUT DATASET *
* - MUST BE DSORG=PO *
* PDR1000 - OPEN OUTPUT DATASET *
* PDR1100 - COPY INPUT DATASET TO OUTPUT DATASET (DATA) *
* - FOR FIRST BLOCK FOLLOWING EACH EOF (FIRST *
* BLOCK IN A MEMBER) IS DONE: *
* - READ BLOCK FROM INPUT DATASET. *
* - CURRENT POS. (TTR) OF INPUT DS. IS NOTED *
* - IF THIS TTR IS FOUND IN ANY OF THE *
* DIRECTORY ENTRIES (INSTORAGE SERIAL SCAN) *
* THAT DIRECTORY ENTRY IS USED TO BUILD *
* STOW INPUT. OTHERWISE A MEMBERNAME IS *
* GENERATED 'PDRV' + MEMBERNUMBER AND USED *
* TO BUILD STOW INPUT. *
* - IF ALL OPTION IS NOT SPECIFIED, ALL 'ALIVE' *
* MEMBERS ARE SKIPPED. MEMBERS WITH *
* NOTELISTS ARE ALWAYS SKIPPED. *
* - IF MEMBER IS NOT TO BE SKIPPED, THE BLOCK *
* IS WRITTEN TO THE OUTPUT DATASET. *
* - PROCESSING DONE FOR OTHER THAN FIRST BLOCK *
* IN MEMBER: *
* - READ BLOCK FROM INPUT DATASET. *
* - IF MEMBER IS NOT TO BE SKIPPED, THE BLOCK *
* IS WRITTEN TO THE OUTPUT DATASET. *
* PDR1200 - SET OUTPUT DCB LIKE INPUT DCB VIA OPEN EXIT *
* PDR1400 - ISSUE USER ABEND 100 *
* PDR1500 - FREE OUTPUT DATASET, IF ALLOCATED *
* PDR1600 - FREE INPUT DATASET, IF ALLOCATED *
* PDR1700 - FREE PDL GETMAINED BY PARSE SERVICE ROUTINE *
* PDR1800 - DCB OPEN EXIT *
* PDR1900 - WRITE A MESSAGE VIA PUTLINE SERVICE ROUTINE *
* PDR2000 - GET DATA FOR MSG13 AND WRITE IT *
* PDR2100 - GET DATA FOR MSG01 AND WRITE IT *
* PDR2200 - HANDLE STOW REQUESTS *
* PDR2300 - INTERFACE TO DAIRFAIL ROUTINE *
* PDR2400 - CONVERT TTR TO CCHHR ADDRESSES *
* *
* MACROS USED: SYSTEM: ABEND CALLTSSR CAMLST CHECK CLOSE DCB *
* FREEMAIN GETMAIN IKJENDP IKJIDENT IKJKEYWD *
* IKJNAME IKJPARM IKJPOSIT IKJRLSA IKJSUBF *
* LINK NOTE OBTAIN OPEN POINT PUTLINE RDJFCB *
* READ RETURN SAVE STOW WRITE *
* LOCAL: DALLOC - SVC 99 INTERFACE *
* *
* *
* MAPPING MACROS: CVT DCBD IECSDSL1 IEFJFCBN IEFZB4D0 IEFZB4D2 *
* IKJCPPL IKJEFFDF IKJIOPL IKJPPL IKJUPT *
* *
***********************************************************************
EJECT
***********************************************************************
* R E G I S T E R E Q U A T E S *
***********************************************************************
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
TITLE 'P D R E S T - MAINLINE'
PDREST CSECT
SAVE (14,12),,PDREST-&SYSDATE-&SYSTIME
*
LR R12,R15 SET UP
LA R10,2048(R12) BASE
LA R10,2048(R10) REGISTERS
USING PDREST,R12,R10 SET BASEREGISTER
*
LR R9,R1 SAVE PARM REGISTER
*
BAL R11,PDR0100 <---------> PERFORM INITIALIZATION
USING SAVE,R13 ESTABLISH ADDRESSABILITY
*
LR R1,R9 RESTORE PARM REGISTER
*
BAL R11,PDR0200 <---------> PARSE PARAMETERS PASSED
*
LTR R15,R15 OK ?
BNZ PDR060 ... NO - EXIT
*
BAL R11,PDR0300 <---------> SET MISCELLANEOUS SWITCHES
LTR R15,R15 OK ?
BNZ PDR1400 ... NO - INTERNAL ERROR
*
BAL R11,PDR0400 <---------> ALLOCATE INPUT DATASET
C R9,F04 ERROR IN DYNALLOC ?
BE PDR050 ... YES, EXIT
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
BAL R11,PDR0500 <---------> CHECK INPUT DATASET ATTRIBUTES
C R9,F04 WRONG ATTRIBUTES ?
BE PDR040 ... YES, FREE INPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... ERROR IN OBTAIN, RDJFCB
*
BAL R11,PDR0600 <---------> OPEN INPUT DATASET
C R9,F04 UNSUCCESSFUL OPEN ?
BE PDR040 ... YES, FREE INPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
BAL R11,PDR0700 <---------> READ INPUT DATASET DIRECTORY
C R9,F04 TOO LITTLE STORAGE ?
BE PDR030 ... YES, CLOSE INPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
PDR010 DS 0H
BAL R11,PDR0800 <---------> ALLOCATE OUTPUT DATASET
C R9,F04 ERROR IN DYNALLOC ?
BE PDR030 ... YES, CLOSE INPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
BAL R11,PDR0900 <---------> CHECK OUTPUT DATASET ATTRIBUTES
C R9,F04 WRONG ATTRIBUTES ?
BE PDR020 ... YES, FREE OUTPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... ERROR IN OBTAIN, RDJFCB
*
BAL R11,PDR1000 <---------> OPEN OUTPUT DATASET
LTR R9,R9 OPEN OK ?
BNZ PDR020 ... NO, FREE OUTPUT DATASET
*
BAL R11,PDR1100 <---------> COPY INPUT -> OUTPUT
C R9,F04 ANY ERRORS ?
BH PDR1400 ... YES
*
BAL R11,PDR1200 <---------> SET ATTRIBUTES FOR OUTPUT DSN
*
PDR020 DS 0H
BAL R11,PDR1500 <---------> FREE OUTPUT DATASET
C R9,F04 ERROR IN DYNALLOC ?
BE PDR030 ... YES, GO CLOSE INPUT DATASET
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
PDR030 DS 0H
L R0,MAXSIZE LENGTH OF AREA
L R1,RECADDR ADDRESS OF AREA
FREEMAIN R,LV=(0),A=(1) FREE RECORD AREA
FREEMAIN VU,A=TABLADDR,MF=(E,FREEMAIL) FREE STORAGE
CLOSE IN,MF=(E,CLOSLIST) CLOSE INPUT DATASET
*
PDR040 DS 0H
BAL R11,PDR1600 <---------> FREE INPUT DATASET
C R9,F04 ERROR IN DYNALLOC ?
BE PDR050 ... YES, GO FREE PDL
LTR R9,R9 OK ?
BNZ PDR1400 ... OTHER ERRORS
*
PDR050 DS 0H
BAL R11,PDR1700 <---------> FREE PDL
*
PDR060 DS 0H
LA R0,LWORK LENGTH TO BE FREED
LR R1,R13 ADDR OF SAVEAREA
L R13,4(,R13) ADDR OF HIGHER SAVEAREA
ST R15,16(,R13) STORE RC IN HIGHER SAVEAREA
FREEMAIN R,LV=(0),A=(1) FREE SAVEAREA
RETURN (14,12) LOAD REGISTERS AND RETURN
TITLE 'P D R E S T - DALLOC MACRO'
MACRO
.**********************************************************************
.* *
.* MACRO FOR SETTING UP DYNAMIC ALLOCATION PARAMETERS AND ISSUING *
.* SVC 99. *
.* *
.* R1 MUST POINT TO A WORKING STORAGE AREA FIRST TIME THIS *
.* MACRO IS CALLED. A DEFINE CONSTANT AFTER LAST MACRO CALL WILL *
.* SHOW THE REQUIRED SIZE OF WORKING STORAGE. *
.* *
.* MAPPING MACROS IEFZB4D0 IEFZB4D2 MUST BE INCLUDED. *
.* *
.* R0,R1,R14,R15 IS DESTROYED. *
.* *
.* R1 AND R15 MAY NOT BE UPDATED BETWEEN FIRST AND LAST DALLOC MACRO *
.* IN AN ALLOCATION SEQUENCE. *
.* *
.* R1 POINTS TO THE RB WHEN RETURNING TO YOUR PROGRAM AFTER THE *
.* LAST MACRO CALL. *
.* *
.* PARAMETERS: DALLOC P0,P1,P2,P3,P4.... OR *
.* DALLOC FLG11=,FLG12=,FLG21=,FLG22= *
.* *
.* EACH MACRO CALL WITH POSITIONAL PARAMETERS IS A REQUEST FOR *
.* GENERATION OF ONE TEXT UNIT. *
.* P0 IS THE ALLOCATION KEY. *
.* P1-P16 IS THE PARAMETERS FOR THE KEY. *
.* *
.* MACRO CALLS WITH NO PARAMETERS OR ONLY KEYWORD PARAMETERS IS A *
.* REQUEST FOR FINISHING THE PARAMETERS FOR THE DYNALLOC REQUEST AND *
.* ISSUING THE DYNALLOC SVC. THE KEYWORD PARAMETERS ARE THE OPTIONAL *
.* FLAGS FOR THE REQUEST BLOCKS. *
.* *
.* P1 TO P16 CAN BE SPECIFIED IN DIFFERENT WAYS: *
.* *
.* *
.* 1. A LABEL OF A STORAGE AREA CONTAINING THE DATA TO BE USED *
.* IN THIS REQUEST *
.* *
.* *
.* 2. A LABEL OF A STORAGE AREA TO RECEIVE THE RETURNED DATA *
.* FOR THE FOLLOWING FUNCTIONS: *
.* *
.* DINRTDDN *
.* DINRTDSN *
.* DINRTMEM *
.* DINRTSTA *
.* DINRTNDP *
.* DINRTCDP *
.* DINRTORG *
.* DINRTLIM *
.* DINRTATT *
.* DINRTLST *
.* DINRTTYP *
.* DALRTDDN *
.* DALRTDSN *
.* DALRTORG *
.* DALRTVOL *
.* *
.* *
.* 3. AN ABSOLUTE VALUE IN ONE OF THE FOLLOWING FORMS: *
.* *
.* A. =C'........' VARIABLE LENGTH *
.* B. =A(.......) VARIABLE LENGTH *
.* C. =ALX(.....) VARIABLE LENGTH *
.* D. C'.' ONE CHAR *
.* E. X'..' ONE CHAR *
.* *
.* *
.* 4. AN ABSOLUTE NUMERIC VALUE (1-5 CHARS) FOR FIXED LENGTH KEYS *
.* FOR THE FOLLOWING FUNCTIONS: *
.* *
.* DALBLKLN *
.* DALPRIME *
.* DALSECND *
.* DALDIR *
.* DALVLSEQ *
.* DALVLCNT *
.* DALUNCNT *
.* DALOUTLM *
.* DALCOPYS *
.* DALDSSEQ *
.* DALEXPDT *
.* DALRETPD *
.* + ALL DCB ATTRIBUTE UNITS *
.* *
.* 5. A SYMBOLIC VALUE FOR SOME KEYS: *
.* *
.* DALSTATS: OLD MOD NEW SHR *
.* DALNDISP: UNCATLG CATLG DELETE KEEP *
.* DALCDISP: UNCATLG CATLG DELETE KEEP *
.* DALSPFRM: ALX MXIG CONTIG *
.* DALLABEL: NL SL NSL SUL BLP LTM AL AUL *
.* DALDEN: 200 556 800 1600 6250 *
.* DALDSORG: PO POU CX DA DAU PS PSU *
.* DALEROPT: T ABE SKP ACC *
.* DALRECFM: M R A G S B D T V F U (OR COMBINATIONS) *
.* *
.* EXAMPLE: *
.* *
.* DALLOC DALDDNAM,=C'SYSUT1' REF: 3.A *
.* DALLOC DALSTATS,NEW REF: 5 *
.* DALLOC DALCYL *
.* DALLOC DALPRIME,=AL3(5) REF: 3.C *
.* DALLOC DALSECND,10 REF: 4 *
.* DALLOC DALSYSOU,CLASS REF: 1 *
.* DALLOC DALLABEL,BLP REF: 5 *
.* DALLOC DALRECFM,FBA REF: 5 *
.* DALLOC FLG21=S99WTVOL+S99WTUNT *
.* *
.* *
.**********************************************************************
.*
.**********************************************************************
.* *
.* CHANGE LOG *
.* *
.* DATE DESCRIPTION PGMR. FIXID*
.* ==== =========== ===== =====*
.* *
.**********************************************************************
.* *
.* *
&NAME DALLOC &P0,&P1,&P2,&P3,&P4,&P5,&P6,&P7,&P8,&P9,&P10,&P11,&P12,X
&P13,&P14,&P15,&P16, X
&FLG11=, S99FLG11 X
&FLG12=, S99FLG12 X
&FLG21=, S99FLG21 X
&FLG22= S99FLG22
.*
LCLA &WORK WORK
LCLA &OFFSET OFFSET USED IN GENERATE
LCLA &C1,&C2,&C3 LOCAL COUNTERS
LCLB &RT THIS FUNCTION RETURNS DATA
LCLB &FT THIS FUNCTION HAS FIXED LEN
LCLC &TEMP TEMPORARY SAVE
LCLC &PX SAVED P1 FOR STATUS FUNC
.*
GBLC &LEN ACCUMULATED WS SIZE
GBLA &TIMES NUMBER OF TIMES CALLED
GBLA &RTNO NUMBER OF ENTRIES IN RC TABL
GBLC &RTOP(25) TABLE OF RECEIVING OPERANDS
GBLA &RTOPL(25) RECEIVING OPERAND LENGTHS
GBLC &FTOP(50) TABLE OF FIXED LNGH OPERANDS
GBLC &FTOPL(50) OPERAND LEN
.*
GBLC &STDT(25) TABLE OF STATUS DATA
GBLC &STPM(25) TABLE OF STATUS PARM
.*
GBLA &RTLEN(25) LENGTH FOR RETURN PARMS
GBLA &RTTIM(25) TIMES VALUE FOR RETURN PARMS
GBLC &RTLAB(25) LABEL FOR RETURN PARMS
.*
GBLC &LCT(25) LOCATION COUNTER
GBLC &VERB DYNALLOC VERB CODE
.*
SPACE 1
.*
AIF ('&NAME' EQ '').A010 IF NO LABEL -->
&NAME DS 0H
.A010 ANOP
.*
&TIMES SETA &TIMES+1 ADD 1 TO TIMES
AIF (K'&P0 EQ 0).A800 IF NO OPERANDS -->
AIF (&TIMES NE 1).A025 IF NOT FIRST TIME -->
.*
.**********************************************************************
.* CODE EXECUTED ONLY FOR FIRST CALL *
.**********************************************************************
.*
LR R15,R1 A(WORKING STORAGE) TO R15
.*
.* TEST FOR KEY TYPE
.*
&VERB SETC 'AL'
AIF ('&P0'(1,3) EQ 'DAL').A020
&VERB SETC 'UN'
AIF ('&P0'(1,3) EQ 'DUN').A020
&VERB SETC 'CC'
AIF ('&P0'(1,3) EQ 'DCC').A020
&VERB SETC 'DC'
AIF ('&P0'(1,3) EQ 'DDC').A020
&VERB SETC 'RI'
AIF ('&P0'(1,3) EQ 'DRI').A020
&VERB SETC 'DN'
AIF ('&P0'(1,3) EQ 'DDN').A020
&VERB SETC 'IN'
AIF ('&P0'(1,3) EQ 'DIN').A020
.A020 ANOP
.*
.* SETUP TABLE OF RECEIVEING FUNCTIONS
.*
&RTOP(1) SETC 'DINRTDDN','DINRTDSN','DINRTMEM','DINRTSTA','DINRTNDP'
&RTOP(6) SETC 'DINRTCDP','DINRTORG','DINRTLIM','DINRTATT','DINRTLST'
&RTOP(11) SETC 'DINRTTYP','DALRTDDN','DALRTDSN','DALRTORG','DALRTVOL'
&RTOPL(1) SETA 8,44,8,1,1
&RTOPL(6) SETA 1,2,2,1,1
&RTOPL(11) SETA 1,8,44,2,6
.*
.* SETUP TABLE OF FIXED LENGTH OPERANDS
.*
&FTOP(1) SETC 'DALBLKLN','DALPRIME','DALSECND','DALDIR','DALVLSEQ'
&FTOP(6) SETC 'DALVLCNT','DALUNCNT','DALOUTLM','DALCOPYS','DALDSSEQ'
&FTOP(11) SETC 'DALEXPDT','DALRETPD'
&FTOP(13) SETC 'DALBFALN','DALBFTEK','DALBLKSZ','DALBUFIN','DALBUFL'
&FTOP(18) SETC 'DALBUFMX','DALBUFNO','DALBUFOF','DALBUFOU','DALBUFRQ'
&FTOP(23) SETC 'DALBUFSZ','DALKYLEN','DALLIMCT','DALLRECL','DALNCP'
&FTOPL(1) SETC '3','3','3','3','2'
&FTOPL(6) SETC '1','1','1','1','2'
&FTOPL(11) SETC '5','2'
&FTOPL(13) SETC '1','1','2','1','2'
&FTOPL(18) SETC '1','1','1','1','1'
&FTOPL(23) SETC '2','1','3','2','1'
.*
.A025 ANOP
.*
.* END OF FIRST TIME CODE
.*
.**********************************************************************
.* TEST FOR RECEIVING FUNCTION *
.**********************************************************************
.*
&C1 SETA 0 SET COUNTER
.A030 ANOP
&C1 SETA &C1+1 ADD ONE TO COUNTER
AIF ('&RTOP(&C1)' EQ '').A035 IF NOT FOUND IN LIST
AIF ('&P0' NE '&RTOP(&C1)').A030 IF NOT THIS ONE
.*
&RT SETB 1 SET INFORMATION RETRIEVAL
&RTNO SETA &RTNO+1 ADD 1 TO ENTRIES IN RT TAB
&RTLEN(&RTNO) SETA &RTOPL(&C1) SAVE OPERAND LENGTH
&RTTIM(&RTNO) SETA &TIMES SAVE TIMES VALUE
&RTLAB(&RTNO) SETC '&P1' SAVE LABEL
.A035 ANOP
.*
.**********************************************************************
.* PROCESS FIRST MACRO PARAMETER *
.**********************************************************************
.*
&C2 SETA 2 SET OPERAND COUNTER
&WORK SETA N'&SYSLIST-1 SET NUMBER OF OPERANDS-1
.*
USING S99TUNIT,R15
LA R0,&P0 GET TEXT UNIT KEY
STH R0,S99TUKEY SAVE IN PARMLIST
LA R0,&WORK GET NUMBER OF OPERANDS
STH R0,S99TUNUM SAVE IN PARMLIST
.*
.**********************************************************************
.* TEST FOR NUMBER OF OPERANDS *
.**********************************************************************
.*
.*
&TEMP SETC '0' SET DATALENGTH TO ZERO
AIF (N'&SYSLIST GT 1).A040 IF MORE THAN ONE PARM -->
.*
.* ONLY ONE PARM SPECIFIED
.*
&LCT(&TIMES) SETC '4' SAVE ENTRY LENGTH
LA R15,4(,R15) POINT AFTER TEXT PARM
DROP R15
SPACE 1
AGO .A900 GO LEAVE -->
.*
.* MORE THAN ONE PARM SPECIFIED - SEE IF FIXED LENGTH OPERAND
.*
.A040 ANOP
AIF (T'&P1 NE 'N').A045 IF NOT NUMERIC
&C1 SETA 0 SET COUNTER
.*
.A042 ANOP
&C1 SETA &C1+1 ADD ONE TO COUNTER
AIF ('&FTOP(&C1)' EQ '').A045 IF NOT FOUND IN LIST
AIF ('&P0' NE '&FTOP(&C1)').A042 IF NOT THIS ONE
&FT SETB 1 SET FIXED LENGTH OPERAND
&TEMP SETC '&FTOPL(&C1)' SET LENGTH
AGO .A065 BRANCH AROUND -->
.*
.A045 ANOP
.*
.* NOT FIXED LENGTH - SEE IF SPECIAL KEY
.*
&TEMP SETC '1' ASSUME LENGTH=1
.*
AIF ('&P0' NE 'DALSTATS').A050A IF NOT DALSTATS
&STDT(1) SETC 'OLD','MOD','NEW','SHR',' '
&STPM(1) SETC '01','02','04','08'
AGO .A053 BRANCH AROUND
.*
.A050A AIF ('&P0' NE 'DALNDISP').A050B IF NOT DALNDISP
&STDT(1) SETC 'UNCATLG','CATLG','DELETE','KEEP',' '
&STPM(1) SETC '01','02','04','08'
AGO .A053 BRANCH AROUND
.*
.A050B AIF ('&P0' NE 'DALCDISP').A050C IF NOT DALCDISP
&STDT(1) SETC 'UNCATLG','CATLG','DELETE','KEEP',' '
&STPM(1) SETC '01','02','04','08'
AGO .A053 BRANCH AROUND
.*
.A050C AIF ('&P0' NE 'DALLABEL').A050C5 IF NOT DALLABEL
&STDT(1) SETC 'NL','SL','NSL','SUL','BLP','LTM','AL','AUL',' '
&STPM(1) SETC '01','02','04','0A','10','21','40','48'
AGO .A053 BRANCH AROUND
.*
.A050C5 AIF ('&P0' NE 'DALSPFRM').A050D IF NOT DALSPFRM
&STDT(1) SETC 'ALX','MXIG','CONTIG',' '
&STPM(1) SETC '02','04','08'
AGO .A053 BRANCH AROUND
.*
.A050D AIF ('&P0' NE 'DALDEN').A051 IF NOT DALDEN
&STDT(1) SETC '200','556','800','1600','6250',' '
&STPM(1) SETC '03','43','83','C3','D3'
AGO .A053 BRANCH AROUND
.*
.A051 AIF ('&P0' NE 'DALEROPT').A052 IF NOT DALEROPT
&STDT(1) SETC 'T','ABE','SKP','ACC',' '
&STPM(1) SETC '10','20','40','80'
AGO .A053 BRANCH AROUND
.*
.A052 AIF ('&P0' NE 'DALRECFM').A052F IF NOT DALRECFM
&STDT(1) SETC 'M','R','A','G','S','B','D','T','V','F','U',' '
&STPM(1) SETC '02','02','04','04','08','10','20','20','40','80','C0'
AGO .A055 BRANCH AROUND - COMBINED
.*
.A052F ANOP
&TEMP SETC '2' ASSUME LENGTH=2
.*
AIF ('&P0' NE 'DALDSORG').A060 IF NOT DALDSORG
&STDT(1) SETC 'PO','POU','CX','DA','DAU','PS','PSU',' '
&STPM(1) SETC '0200','0300','1000','2000','2100','4000','4100'
AGO .A053 BRANCH AROUND
.*
.* SPECIAL KEY FOUND
.*
.A053 ANOP
&C1 SETA 0 INIT COUNTER
.A054 ANOP
&C1 SETA &C1+1 ADD ONE TO COUNTER
AIF ('&STDT(&C1)' EQ ' ').A060 IF NOT FOUND IN LIST
AIF ('&P1' NE '&STDT(&C1)').A054 IF NOT THIS ONE
&PX SETC 'X'.'''&STPM(&C1)'''.' SET PARM FOR ''&P1'''
AGO .A065
.*
.* SPECIAL COMBINED KEY FOUND
.*
.A055 ANOP
&C3 SETA 0 INIT COUNTER
.A056 ANOP
&C3 SETA &C3+1 ADD ONE TO COUNTER
AIF (&C3 GT K'&P1).A059 IF NO MORE OPERANDS
&C1 SETA 0 INIT COUNTER
.A057 ANOP
&C1 SETA &C1+1 ADD ONE TO COUNTER
AIF ('&STDT(&C1)' EQ ' ').A058 IF NOT FOUND IN LIST
AIF ('&P1'(&C3,1) NE '&STDT(&C1)').A057 IF NOT THIS ONE
&PX SETC '&PX'.'+X'.'''&STPM(&C1)'''
AGO .A056
.*
.A058 ANOP
&PX SETC '' RESET PX
AGO .A060 DROP SPECIAL KEY
.*
.A059 ANOP
&PX SETC '&PX'.' SET PARM FOR ''&P1'''
AGO .A065 BRANCH AROUND
.*
.* END OF TEST FOR SPECIAL KEYS
.*
.**********************************************************************
.* CALCULATE DATALENGTH IF NOT SPECIAL KEY *
.**********************************************************************
.*
.A060 ANOP
AIF (K'&P1 LE 4).A063 IF LENGTH<5
&TEMP SETC '1' ASSUME LENGTH=1
AIF ('&P1'(2,1) EQ '''').A065 IF .'...
.*
&TEMP SETC '&P1'(4,1) ASSUME DATA LENGTH
AIF ('&P1'(1,3) EQ '=AL').A065 IF =AL
.*
&TEMP SETC '4' ASSUME LENGTH=4
AIF ('&P1'(1,2) EQ '=A').A065 IF =A
.*
&WORK SETA K'&P1-4 SET LENGTH=L-4
&TEMP SETC '&WORK' ASSUME DATA LENGTH
AIF ('&P1'(1,1) EQ '=').A065 IF =
.*
.A063 ANOP
&TEMP SETC 'L'''.'&P1' ASSUME DATA LENGTH
AIF (NOT &RT).A065 IF NOT INFO RETRIEVAL
&TEMP SETC '&RTLEN(&RTNO)' SET DATA LENGTH
.*
.A065 ANOP
&LCT(&TIMES) SETC '&TEMP'.'+6' SAVE ENTRY LENGTH
.*
.* END OF LENGTH CALCULATION
.*
LA R0,&TEMP GET DATA LENGTH
STH R0,S99TULNG SAVE IN PARMLIST
.*
AIF (&FT).A080 IF FIXED LENGTH OPERAND
AIF (&RT).A090 IF INFORMATION RETRIEVAL
AIF (K'&PX NE 0).A069 IF SPECIAL NAME
AIF ('&P1'(2,1) NE '''').A075 IF NOT .'...
.*
MVI S99TUPAR,&P1 MOVE DATA TO PARMLIST
AGO .A090
.*
.A069 AIF ('&TEMP' NE '1').A070 IF LENGTH NOT 1 -->
MVI S99TUPAR,&PX
AGO .A090
.*
.A070 ANOP
MVC S99TUPAR(2),=&PX
AGO .A090
.*
.A075 ANOP
MVC S99TUPAR(&TEMP),&P1 MOVE DATA TO PARMLIST
AGO .A090
.*
.A080 ANOP
AIF ('&TEMP' EQ '1').A082 IF LENGTH IS 1 -->
AIF ('&TEMP' EQ '5').A084 IF LENGTH IS 5 -->
.*
MVC S99TUPAR(&TEMP),=AL&TEMP.(&P1) MOVE DATA TO PARMLIST
AGO .A090
.*
.A082 ANOP
MVI S99TUPAR,&P1 MOVE DATA TO PARMLIST
AGO .A090
.*
.A084 ANOP
MVC S99TUPAR(&TEMP),=CL&TEMP.'&P1' MOVE DATA TO PARMLIST
AGO .A090
.*
.A090 ANOP
LA R15,&TEMP+6(,R15) POINT AFTER TEXT PARM
DROP R15
SPACE 1
.*
.A100 ANOP
&C2 SETA &C2+1 ADD 1 TO OPERAND COUNTER
AIF (&C2 GT N'&SYSLIST).A900 IF NO MORE OPERANDS -->
&C1 SETA &C2 USE &C1 IN NEXT ROUTINE
.*
.**********************************************************************
.* PROCESS SUBSEQUENT MACRO PARAMETERS *
.**********************************************************************
.*
AIF (K'&SYSLIST(&C1) LE 6).A200 IF LENGTH<6
&TEMP SETC '&SYSLIST(&C1)'(4,1) ASSUME DATA LENGTH
AIF ('&SYSLIST(&C1)'(1,3) EQ '=AL').A300 IF =AL
.A200 ANOP
.*
&TEMP SETC '4' ASSUME LENGTH=4
AIF ('&SYSLIST(&C1)'(1,2) EQ '=A').A300 IF =A
.*
&WORK SETA K'&SYSLIST(&C1)-4 SET LENGTH=L-4
&TEMP SETC '&WORK' ASSUME DATA LENGTH
AIF ('&SYSLIST(&C1)'(1,1) EQ '=').A300 IF =
.*
&TEMP SETC 'L'''.'&SYSLIST(&C1)' SET DATA LENGTH FOR NEXT
.*
.A300 ANOP
&LCT(&TIMES) SETC '&LCT(&TIMES)'.'+&TEMP'.'+8' GET TEXT POINTER
.*
SPACE 1
USING S99TUFLD,R15
LA R0,&TEMP GET DATA LENGTH
STH R0,S99TULEN SAVE IN PARMLIST
MVC S99TUPRM(&TEMP),&SYSLIST(&C1) MOVE DATA TO PARMLIST
LA R15,&TEMP+2(,R15) POINT AFTER TEXT UNIT
DROP R15
SPACE 1
.*
AGO .A100
.*
.**********************************************************************
.* GENERATE FINAL CODE *
.**********************************************************************
.*
.A800 ANOP
AIF (&TIMES EQ 1).A900 IF NOTHING
&OFFSET SETA 0 SET OFFSET=0
&C1 SETA 1 SET COUNTER
.*
SPACE 1
LA R15,3(,R15) ADJUST
SRL R15,2 TO FULLWORD
SLL R15,2 BOUNDARY
SPACE 1
.*
AGO .A820 GO FIRST TIME
.*
.A810 ANOP
&OFFSET SETA &OFFSET+4 SET NEW OFFSET
.*
SPACE 1
LA R1,&LCT(&C1)(,R1) POINT TO NEXT TEXTUNIT
.*
&C1 SETA &C1+1 ADD 1 TO COUNTER
.A820 ANOP
.*
ST R1,&OFFSET.(,R15) SAVE POINTER TO TEXTUNIT
.*
AIF (&C1 NE &TIMES-1).A810
.*
OI &OFFSET.(R15),S99TUPLN SETON HIGHORDER BIT IN LAST
.*
&OFFSET SETA &OFFSET+4 SET NEW OFFSET
.*
.* BUILD REQUEST BLOCK
.*
SPACE 1
LA R1,&OFFSET.(,R15) POINT TO RB
USING S99RB,R1
XC S99RB(S99RBEND-S99RB),S99RB CLEAR RB AREA
ST R15,S99TXTPP SAVE A(TEXT UNITS)
MVI S99RBLN,X'14' LENGTH OF BLOCK
MVI S99VERB,S99VRB&VERB VERB CODE
.*
AIF (K'&FLG11 EQ 0).A830 IF FLG11 NOT SPEC.
MVI S99FLG11,&FLG11 SET S99FLG11
.*
.A830 AIF (K'&FLG12 EQ 0).A835 IF FLG12 NOT SPEC.
MVI S99FLG12,&FLG12 SET S99FLG12
.*
.A835 AIF (K'&FLG21 EQ 0).A840 IF FLG21 NOT SPEC.
MVI S99FLG21,&FLG21 SET S99FLG21
.*
.A840 AIF (K'&FLG22 EQ 0).A845 IF FLG22 NOT SPEC.
MVI S99FLG22,&FLG22 SET S99FLG22
.*
.A845 ANOP
.*
LR R14,R1 A(RB TO R14)
DROP R1
SPACE 1
USING S99RBP,R1
LA R1,S99RBEND-S99RB(,R1) POINT TO RB POINTER
ST R14,S99RBPTR SAVE POINTER TO RB
OI S99RBPTR,S99RBPND SETON HIGHORDER BIT
DROP R1
SPACE 1
SVC 99 ISSUE DYNALLOC SVC
SPACE 1
LR R1,R14 RELOAD RB POINTER
SPACE 1
.*
.* PROCESS RETURN PARMS IF ANY
.*
AIF (&RTNO EQ 0).A870 IF NOTHING TO RETURN
.*
&C1 SETA 0 RESET COUNTER
.A850 ANOP
&C1 SETA &C1+1 ADD 1 TO COUNTER
AIF (&C1 GT &RTNO).A860 IF NO MORE ENTRIES
&WORK SETA (&RTTIM(&C1)-1)*4 OFFSET TO TEXTUNIT PTR
&TEMP SETC '&RTLAB(&C1)(&RTLEN(&C1)' BUILD TARGET FOR MOVE
.*
USING S99RB,R1 TELL ASSEMBLER
L R14,S99TXTPP GET ADDR OF TEXT UNIT PNTER
USING S99TUPL,R14 TELL ASSEMBLER
L R14,S99TUPTR+&WORK GET ADDR OF TEXT UNIT
USING S99TUNIT,R14 TELL ASSEMBLER
MVC &TEMP),S99TUPAR MOVE RESULT
DROP R14
.*
AGO .A850
.*
.A860 ANOP
DROP R1 TELL ASSEMBLER
.*
.A870 ANOP
.*
SPACE 1
&WORK SETA (&TIMES*4)+24 ADD TO STORAGE LENGTH
DC Y(&LEN+&WORK) REQUIRED LENGTH OF WORKING STORAGE
ORG *-2
SPACE 1
.*
&LEN SETC '' RESET WORKING STORAGE SIZE
&RTNO SETA 0 RESET RETURN VALUE
&TIMES SETA 0 RESET TIMES
AGO .A950 BRANCH AROUND
.*
.A900 ANOP
&LEN SETC '&LEN'.'+&LCT(&TIMES)' ADD TO STORAGE LENGTH
.*
.A950 ANOP
MEXIT
.*
MEND
TITLE 'P D R E S T - PDR0100'
***********************************************************************
* PDR0100 *
***********************************************************************
PDR0100 DS 0H
*
* THIS ROUTINE PERFORMS INITIALIZATION FOR PDREST.
* E.G. GETMAIN STORAGE AND CHAIN SAVEAREAS AND SET UP DSECTS.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - WORK
* R4 - WORK
* R5 - WORK
* R6 - WORK
* R7 - WORK
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
*
DROP R13
LA R0,LWORK LENGTH TO BE GETMAINED
GETMAIN R,LV=(0) ISSUE GETMAIN SVC
LR R2,R1 ADDR OF GETMAINED STORAGE
LA R3,LWORK LENGTH TO CLEAR
SR R5,R5 SET LGTH2 = 0 -> CLEAR
MVCL R2,R4 CLEAR AREA
USING SAVE,R1 ESTABLISH ADDRESSABILITY
LA R4,WORK ADDR OF AREA TO RECEIVE
LA R5,INITLGTH LENGTH TO MOVE
LA R6,INIT ADDR OF DATA TO MOVE
LR R7,R5 LENGTH TO MOVE
MVCL R4,R6 MOVE IT
ST R13,4(R1) LINK IN NEW SA TO OLD SA
ST R1,8(R13) LINK IN OLD SA TO NEW SA
LR R13,R1 NEW SAVEAREA ADDR IN REGISTER 13
DROP R1
USING SAVE,R13 ESTABLISH ADDRESSABILITY
BR R11 RETURN TO MAINLINE
TITLE 'P D R E S T - PDR0200'
***********************************************************************
* PDR0200 *
***********************************************************************
PDR0200 DS 0H
*
* THIS ROUTINE BUILDS CONTROL BLOCKS NEEDED FOR TSO SERVICE ROUTINES
* AND PARSES PARAMETERS PASSED TO PDREST.
*
* REGISTER ASSIGNMENT:
*
* R3 - BASE FOR PPL
* R4 - WORK
* R8 - BASE FOR IOPL
* R9 - BASE FOR CPPL
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
*
ST R9,CPPLADDR SAVE CPPL ADDR FOR DAIRFAIL
USING CPPL,R9 ESTABLISH ADDRESSABILITY
LA R3,PPLAREA ADDR OF PARSE PARAMETER LIST
USING PPL,R3 ADDRESSABILITY
LA R8,IOPLAREA ADDR OF I/O PARAMETER LIST
USING IOPL,R8 ADDRESSABILITY
L R4,CPPLCBUF ADDR OF COMMAND BUFFER
ST R4,PPLCBUF STORE IN PPL
L R4,CPPLUPT ADDR OF USER PROFILE TABLE
MVC PREFIX(8),UPTPREFX-UPT(R4) SAVE USERID PREFIX
ST R4,PPLUPT STORE IN PPL
ST R4,IOPLUPT STORE IN IOPL
L R4,CPPLECT ADDR OF ENVIRONMENT CTL TABLE
ST R4,PPLECT STORE IN PPL
ST R4,IOPLECT STORE IN IOPL
LA R4,ECB ADDR OF ATTENTION ECB
ST R4,PPLECB STORE IN PPL
ST R4,IOPLECB STORE IN IOPL
L R4,PCLADDR ADDR OF PCL
ST R4,PPLPCL STORE PCL ADDR
LA R4,PDLADDR ADDR OF POINTER TO ANSWER AREA
ST R4,PPLANS STORE IN PPL
ST R13,UWA R13 SAVED IN UWA
LA R4,UWA USER WORKING AREA
ST R4,PPLUWA STORE ADDR IN PPL
DROP R3,R9
CALLTSSR EP=IKJPARS,MF=(E,PPLAREA) I K J P A R S
BR R11 RETURN
TITLE 'P D R E S T - PDR0300'
***********************************************************************
* PDR0300 *
***********************************************************************
PDR0300 DS 0H
*
* THIS ROUTINE SET SWITCHES BASED ON KEYWORDS SPECIFIED TO PDREST.
*
* REGISTER ASSIGNMENT:
*
* R1 - WORK
* R8 - BASE FOR PDL
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R15 - RETURN CODE
*
***********************************************************************
* PROCESS DELETED/ALL KEYWORDS *
***********************************************************************
L R8,PDLADDR ADDR OF PDL
LA R15,4 SET BAD RETURNCODE
LH R1,MODE-PDL(,R8) EQUALS 1 OR 2 (DELETED/ALL)
*
C R1,F02 2. KEYWORD SPECIFIED ?
BE PDR0310 ... YES, DON'T CHANGE SWITCH
C R1,F01 1. KEYWORD SPECIFIED ?
BNER R11 ... ERROR
*
NI FLAGS,X'FF'-COPYALL INDICATES ONLY DELETED MEMBERS
***********************************************************************
* PROCESS REPLACE/NOREPLACE KEYWORDS *
***********************************************************************
PDR0310 DS 0H
LH R1,REPLACE-PDL(,R8) EQUALS 1 OR 2 (REPLACE/NOREPL)
*
C R1,F02 2. KEYWORD SPECIFIED ?
BE PDR0320 ... YES, DON'T CHANGE SWITCH
C R1,F01 1. KEYWORD SPECIFIED ?
BNER R11 ... ERROR
*
OI FLAGS,REPLOPT INDICATE REPLACE OPTION
***********************************************************************
* PROCESS DEBUG/NODEBUG KEYWORDS *
***********************************************************************
PDR0320 DS 0H
LH R1,DEBUG-PDL(,R8) EQUALS 1 OR 2 (DEBUG/NODEBUG)
*
C R1,F02 2. KEYWORD SPECIFIED ?
BE PDR0330 ... YES, DON'T CHANGE SWITCH
C R1,F01 1. KEYWORD SPECIFIED ?
BNER R11 ... ERROR
*
OI FLAGS,DEBUGOPT INDICATE DEBUG OPTION
PDR0330 DS 0H
SLR R15,R15 SET GOOD RETURNCODE
BR R11 ... AND RETURN
TITLE 'P D R E S T - PDR0400'
***********************************************************************
* PDR0400 *
***********************************************************************
PDR0400 DS 0H
*
* THIS ROUTINE PERFORM ALLOCATION OF INPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - WORK
* R4 - LINKAGE REGISTER
* R8 - BASE FOR PDL
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
***********************************************************************
* PROCESS INDATASET/INFILE KEYWORDS *
***********************************************************************
L R8,PDLADDR ADDR OF PDL
LA R9,8 SET BAD RETURNCODE
LH R1,IDS-PDL(,R8) EQUALS 1, 2, 3 OR 4
*
C R1,F03 3. KEYWORD SPECIFIED ?
BE PDR0430 ... YES, PROCESS INFILE
C R1,F04 4. KEYWORD SPECIFIED ?
BE PDR0430 ... YES, PROCESS INFILE
BHR R11 ... ERROR
C R1,F01 1. KEYWORD SPECIFIED ?
BLR R11 ... ERROR
*
***********************************************************************
* PROCESS INDATASET/IDS KEYWORDS *
***********************************************************************
L R1,IDS2-PDL(,R8) POINTER TO IDS2 PARAMETER
MVI $IDS,C' ' CLEAR
MVC $IDS+1(43),$IDS OUTPUT BUFFER
LH R15,IDS2+4-PDL(,R8) LENGTH OF IDS2 PARAMETER
STH R15,@IDS STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$IDS ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
TM IDS2+6-PDL(R8),X'40' IS DSNAME IN QUOTES ?
BNZ PDR0410 ... YES
MVC WDATASET(44),$IDS MOVE DSNAME TO WORK BUFFER
SR R1,R1 ZERO R1
IC R1,PREFIX+7 LENGTH OF USERID PREFIX
LTR R1,R1 ZERO ?
BE PDR0410 ... YES
BCTR R1,0 DECREMENT FOR USE WITH EXECUTE
EX R1,PREFMOV1 INSERT PREFIX IN DSNAME
LA R2,$IDS+1(R1) ADDR FOLLOWING PREFIX
MVI 0(R2),C'.' INSERT SEPARATOR
LH R3,@IDS LENGTH OF DSNAME
BCTR R3,0 DECREMENT FOR USE WITH EXECUTE
EX R3,DSNMOVE MOVE IT BACK INTO IT'S NEW PLACE
LA R1,3(R3,R1) NEW DSNAME LENGTH
STH R1,@IDS STORE IN LENGTH PREFIX
PDR0410 DS 0H
L R1,IPASS-PDL(,R8) POINTER TO IPASS PARAMETER
MVI $IPASS,C' ' CLEAR
MVC $IPASS+1(7),$IPASS OUTPUT BUFFER
LA R15,0 LENGTH OF DEF. VALUE FOR IPASS
STH R15,@IPASS STORE LENGTH
LTR R1,R1 IS IPASS PRESENT ?
BZ PDR0420 ... NO
LH R15,IPASS+4-PDL(,R8) LENGTH OF IPASS PARAMETER
STH R15,@IPASS STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$IPASS ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
PDR0420 DS 0H
EJECT
***********************************************************************
* ALLOCATE INDATASET USING SVC 99 *
***********************************************************************
LA R0,8 LENGTH OF RETURNED DDNAME
STH R0,@IFILE STORE IN LENGTH PREFIX FOR FILE
LA R1,S99 ADDRESS OF WORK AREA
DALLOC DALRTDDN,$IFILE
DALLOC DALDSNAM,$IDS
DALLOC DALPASSW,$IPASS
DALLOC DALSTATS,SHR
DALLOC
LR R3,R1 ADDRESS OF SVC 99 REQUEST BLOCK
OI SWITCH,IALLOC SET IALLOC SWITCH
LTR R9,R15 OK ?
BZR R11 ... YES
BAL R4,PDR2300 <----------> INVOKE DAIRFAIL ROUTINE
BR R11 ... RETURN
PREFMOV1 MVC $IDS(*-*),PREFIX STATEMENT WILL BE EXECUTED
EJECT
***********************************************************************
* PROCESS INFILE/IFILE KEYWORDS *
***********************************************************************
PDR0430 DS 0H
L R1,IFILE2-PDL(,R8) POINTER TO IFILE2 PARAMETER
MVI $IFILE,C' ' CLEAR
MVC $IFILE+1(7),$IFILE OUTPUT BUFFER
LH R15,IFILE2+4-PDL(,R8) LENGTH OF IFILE2 PARAMETER
STH R15,@IFILE STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$IFILE ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
SLR R9,R9 SET GOOD RETURN CODE
BR R11 ... RETURN
TITLE 'P D R E S T - PDR0500'
***********************************************************************
* PDR0500 *
***********************************************************************
PDR0500 DS 0H
*
* THIS ROUTINE CHECKS ATTRIBUTES OF INPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
LA R9,8 SET ERROR RETURN CODE
MVC READDCB+DCBDDNAM-IHADCB(8),$IFILE INSERT DDNAME
LA R0,JFCB ADDR OF WORKAREA
STCM R0,B'0111',JFCBADDR SAVE IT IN EXIT LIST
LA R0,EXLIST ADDR OF EXIT LIST
STCM R0,B'0111',READDCB+DCBEXLSA-IHADCB SAVE IT IN DCB
RDJFCB READDCB,MF=(E,RDJFCBL) READ JFCB FOR SPECIFIED DDNAME
LTR R15,R15 OK ?
BZ PDR0510 ... YES
CH R15,H04 RC 04 ?
BNER R11 ... NO, ABEND
LA R9,4 SET ERROR RETURN CODE
MVC MSG19+18(8),$IFILE INSERT DDNAME IN MESSAGE
LA R1,MSG19 'DDNAME -------- IS MISSING'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R11 ... AND EXIT
PDR0510 DS 0H
LA R9,8 SET ERROR RETURN CODE
LA R0,JFCBDSNM ADDR OF JFCB DSNAME
ST R0,OBTLIST+4 SAVE IN CAMLST
LA R0,JFCBVOLS ADDR OF JFCB VOLSER
ST R0,OBTLIST+8 SAVE IN CAMLST
LA R0,OBTAINWA ADDR OF OBTAIN WORK AREA
ST R0,OBTLIST+12 SAVE IN CAMLST
OBTAIN OBTLIST READ DSCB FOR DSN IN JFCB
LTR R15,R15 OK ?
BZ PDR0520 ... YES
CH R15,H08 RC 08 ?
BNER R11 ... NO, ABEND
LA R9,4 SET ERROR RETURN CODE
MVC MSG20+42(6),JFCBVOLS INSERT VOLSER IN MESSAGE
LA R1,MSG20 'INPUT DS ... NOT ON VOLUME'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R11 ... AND EXIT
PDR0520 DS 0H
LA R9,4 SET ERROR RETURN CODE
CLC DS1DSORG(2),DSORGPO DSORG PO ?
BE PDR0530 ... YES
LA R1,MSG21 'INPUT DS ... NOT PARTITIONED'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R11 ... AND EXIT
PDR0530 DS 0H
MVC INLRECL(2),DS1LRECL MOVE LRECL VALUE
MVC INBLOCK(2),DS1BLKL MOVE BLKSIZE VALUE
MVC INRECFM(1),DS1RECFM MOVE RECFM CODE
MVC LASTIN(3),DS1LSTAR MOVE LAST BLOCK POINTER
SLR R1,R1 CLEAR R0
ICM R1,B'0011',DS1LSTAR GET LAST TRACK USED
LA R1,1(,R1) CONVERT TO NUMBER OF TRACKS
STCM R1,B'0111',$PRIME SAVE IT IN TEXT UNIT
MVC @PRIME(2),H03 SET LENGTH OF $PRIME
SLR R9,R9 SET GOOD RETURN CODE
BR R11 ... AND RETURN
TITLE 'P D R E S T - PDR0600'
***********************************************************************
* PDR0600 *
***********************************************************************
PDR0600 DS 0H
*
* THIS ROUTINE OPENS INPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
LA R9,8 SET BAD RETURN CODE
DEVTYPE $IFILE,DEVAREA,DEVTAB GET MAX RECORD SIZE
LTR R15,R15 OK ?
BNZR R11 ... NO
L R0,DEVAREA+4 GET MAX RECORD SIZE ON DEVICE
ST R0,MAXSIZE ... AND SAVE IT
GETMAIN R,LV=(0) GET STORAGE FOR RECORD AREA
ST R1,RECADDR SAVE ADDRESS OF AREA
*
SLR R9,R9 SET GOOD RETURNCODE
MVC IN+DCBDDNAM-IHADCB(8),$IFILE INSERT DDNAME
OPEN (IN,(INPUT)),MF=(E,OPENLST2)
TM IN+DCBOFLGS-IHADCB,DCBOFOPN INPUT DS OPEN OK ?
BOR R11 ... YES, RETURN
LA R9,4 SET BAD RETURNCODE
MVC MSG12+40(8),$IFILE INSERT DDNAME
LA R1,MSG12 'UNSUCCESSFUL OPEN ...'
BAL R3,PDR1900 <----------------> WRITE MESSAGE
BR R11 ... AND EXIT
TITLE 'P D R E S T - PDR0700'
***********************************************************************
* PDR0700 *
***********************************************************************
PDR0700 DS 0H
*
* THIS ROUTINE READS DIRECTORY FOR INPUT DATASET INTO STORAGE.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK + LINKAGE REGISTER
* R3 - LINKAGE REGISTER
* R4 - BASE FOR DIRENTRY
* R7 - WORK
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
GETMAIN VU,LA=DIRMIN,A=TABLADDR,MF=(E,GETMAINL) GET STORAGE
L R4,TABLADDR GET ADDR OF STORAGE
A R4,DIRSPACE GET ADDR FOLLOWING DIR. STG.
LA R4,0(,R4) CLEAR HIGH ORDER BYTE
ST R4,DIRHIGHA SAVE IT
L R4,TABLADDR GET ADDR OF STORAGE
USING DIRENTRY,R4 ADDRESSABILITY
XC LINK(4),LINK CLEAR LINK
SLR R0,R0 R0 := 0
ST R0,DIRBLKN INIT ZERO DIRBLKS
ST R0,MEMBERN INIT ZERO MEMBERS
PDR0710 DS 0H
L R2,RECADDR ADDR OF BUFFER
LA R3,IN ADDR OF DCB
L R7,MAXSIZE MAXIMUM TRACK SIZE
READ DECBIN,SF,(R3),(R2),(R7),MF=E READ A DIRECTORY BLOCK
CHECK DECBIN CHECK IF I/O OK
LH R0,DECBIN+6 REQUESTED LENGTH (MAXSIZE)
L R1,DECBIN+16 IOB ADDR
SH R0,14(,R1) SUBTRACT RESIDUAL COUNT
STH R0,RECSIZE SAVE SIZE OF RECORD JUST READ
LA R9,8 ASSUME ERROR
LA R1,IN ADDR OF DCB
BAL R2,PDR2000 <----------> WR. 'TTR OF LAST BLOCK READ ...'
LTR R0,R9 OK ?
BNZ 0(R11) ... NO
SR R9,R9 ASSUME OK
L R15,DIRBLKN CURRENT DIRECTORY BLOCK COUNT
LA R15,1(,R15) INCREMENT DIRECTORY COUNT
ST R15,DIRBLKN SAVE DIRECTORY BLOCK COUNT
L R1,RECADDR ADDR OF DIRECTORY BLOCK READ
LH R15,0(R1) LENGTH OF DIRECTORY BLOCK
LTR R15,R15 IS IT EMPTY ?
BZ PDR0710 ... YES
LA R15,0(R1,R15) ADDR FOLLOWING DIRECTORY BLOCK
ST R15,DIRBLKE SAVE IT
LA R1,2(R1) ADDR OF MEMBER
PDR0720 DS 0H
C R1,DIRBLKE PAST END OF DIRECTORY BLOCK ?
BNL PDR0710 ... YES
CLC 0(8,R1),ENDMARK IS IT AN END MARKER ?
BE PDR0710 ... YES
SR R15,R15 R15 := 0
LA R14,12 LENGTH OF ENTRY WITH NO USERDATA
IC R15,11(R1) SPECIAL FLAGS
N R15,USERNUM NUMBER OF USER DATA HALFWORDS
BZ PDR0730 ... NONE
AR R14,R15 LENGTH OF
AR R14,R15 COMPLETE ENTRY (R15 HALFWORDS)
PDR0730 DS 0H
BCTR R14,0 DECREMENT FOR USE WITH EXECUTE
EX R14,MOVEMEM CREATE ENTRY IN TABLE
LA R14,1(R14) RESTORE AFTER EXECUTE USE
L R15,MEMBERN CURRENT MEMBER COUNT
LA R15,1(,R15) INCREMENT MEMBER COUNT
ST R15,MEMBERN SAVE MEMBER COUNT
LA R0,4(R14,R4) ADDR OF FREE STORAGE
ST R0,LINK STORE IN LINK
LR R4,R0 UPDATE USING
LA R0,LINK+DIRENTLG+4 SPACE FOR EXTRA ENTRY + LINK
C R0,DIRHIGHA OUT OF SPACE ?
BNL PDR0740 ... YES
XC LINK(4),LINK CLEAR LINK
AR R1,R14 UPDATE POINTER IN BLOCK
B PDR0720 TEST NAME
PDR0740 DS 0H
LA R9,4 SET BAD RETURN CODE
LA R1,MSG25 'NOT ENOUGH SPACE GETMAINED ...'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R11 ... RETURN
MOVEMEM MVC MEMBER(*-*),0(R1) WILL BE EXECUTED
DROP R4
***********************************************************************
* E O F P R O C E S S I N G F O R D I R E C T O R Y *
***********************************************************************
PDR0750 DS 0H
XC RECSIZE(2),RECSIZE LENGTH ZERO FOR EOF
LA R1,IN ADDR OF DCB
MVC MSG13+18(4),TEOF WE NOW READ EOF
BAL R2,PDR2000 <----------> WR. 'TTR OF LAST BLOCK READ ...'
MVC MSG13+18(4),TDATA WE NOW READ DATA
LTR R0,R9 OK ?
BNZ 0(R11) ... NO
SR R9,R9 ASSUME OK
L R15,DIRBLKN GET NUMBER OF DIRECTORY BLOCKS
STCM R15,B'0111',$DIRBLK SAVE NUMBER OF DIRECTORY BLOCKS
MVC @DIRBLK(2),H03 SET LENGTH FIELD
CVD R15,PACK CONVERT TO PACKED DECIMAL
UNPK MSG14+25(4),PACK(8) CONVERT TO ZONED
OI MSG14+25+3,X'F0' SET ZONE IN SIGN BYTE
L R15,MEMBERN GET NUMBER OF MEMBERS
CVD R15,PACK CONVERT TO PACKED DECIMAL
UNPK MSG14+39(5),PACK(8) CONVERT TO ZONED
OI MSG14+39+4,X'F0' SET ZONE IN SIGN BYTE
TM FLAGS,DEBUGOPT DEBUG OPTION IN EFFECT ?
BNO PDR0760 ... NO
LA R1,MSG14 '***EOF'
BAL R3,PDR1900 <----------> WRITE MESSAGE
PDR0760 DS 0H
OI FLAGS,FIRST SET FIRST SWITCH
NI FLAGS,X'FF'-DIR RESET DIR FLAG
NOTE IN TTR OF EOF MARK
ST R1,POINTTTR RETURNED IN REGISTER 1
MVI POINTTTR+3,X'01' TTR OF FIRST BLOCK AFTER EOF
LA R9,4 END OF DATASET RETURN CODE
C R1,LASTIN EQUAL TO LAST BLOCK PTR ?
BER R11 ... YES -> EXIT
POINT IN,POINTTTR NEXT READ AT THAT TTR
LA R0,PDR1135 ADDRESS OF EOF ROUTINE FOR DATA
STCM R0,B'0111',IN+DCBEODA-IHADCB SAVE IN DCB
MVC MSG13+18(4),TDATA WE NOW READ DATA
SLR R9,R9 SET GOOD RETURN CODE
BR R11 RETURN
TITLE 'P D R E S T - PDR0800'
***********************************************************************
* PDR0800 *
***********************************************************************
PDR0800 DS 0H
*
* THIS ROUTINE PERFORM ALLOCATION OF OUTPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - WORK + LINKAGE REGISTER
* R8 - BASE FOR PDL
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
***********************************************************************
* PROCESS OUTDATASET/OUTFILE KEYWORDS *
***********************************************************************
L R8,PDLADDR GET ADDR OF PDL
LA R9,8 SET BAD RETURNCODE
LH R1,ODS-PDL(,R8) EQUALS 1, 2, 3 OR 4
*
C R1,F03 3. KEYWORD SPECIFIED ?
BE PDR0850 ... YES, PROCESS OUTFILE
C R1,F04 4. KEYWORD SPECIFIED ?
BE PDR0850 ... YES, PROCESS OUTFILE
BHR R11 ... ERROR
C R1,F01 1. KEYWORD SPECIFIED ?
BLR R11 ... ERROR
*
***********************************************************************
* PROCESS OUTDATASET/ODS KEYWORDS *
***********************************************************************
L R1,ODS2-PDL(,R8) POINTER TO ODS2 PARAMETER
MVI $ODS,C' ' CLEAR
MVC $ODS+1(43),$ODS OUTPUT BUFFER
LH R15,ODS2+4-PDL(,R8) LENGTH OF ODS2 PARAMETER
STH R15,@ODS STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$ODS ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
TM ODS2+6-PDL(R8),X'40' IS DSNAME IN QUOTES ?
BNZ PDR0810 ... YES
MVC WDATASET(44),$ODS MOVE DSNAME TO WORK BUFFER
SR R1,R1 ZERO R1
IC R1,PREFIX+7 LENGTH OF USERID PREFIX
LTR R1,R1 ZERO ?
BE PDR0810 ... YES
BCTR R1,0 DECREMENT FOR USE WITH EXECUTE
EX R1,PREFMOV2 INSERT PREFIX IN DSNAME
LA R2,$ODS+1(R1) ADDR FOLLOWING PREFIX
MVI 0(R2),C'.' INSERT SEPARATOR
LH R3,@ODS LENGTH OF DSNAME
BCTR R3,0 DECREMENT FOR USE WITH EXECUTE
EX R3,DSNMOVE MOVE IT BACK INTO IT'S NEW PLACE
LA R1,3(R3,R1) NEW DSNAME LENGTH
STH R1,@ODS STORE IN LENGTH PREFIX
PDR0810 DS 0H
L R1,OPASS-PDL(,R8) POINTER TO OPASS PARAMETER
MVI $OPASS,C' ' CLEAR
MVC $OPASS+1(7),$OPASS OUTPUT BUFFER
LA R15,0 LENGTH OF DEF. VALUE FOR OPASS
STH R15,@OPASS STORE LENGTH
LTR R1,R1 IS OPASS PRESENT ?
BZ PDR0820 ... NO
LH R15,OPASS+4-PDL(,R8) LENGTH OF OPASS PARAMETER
STH R15,@OPASS STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$OPASS ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
PDR0820 DS 0H
EJECT
***********************************************************************
* ALLOCATE OUTDATASET USING SVC 99 *
***********************************************************************
LA R0,8 LENGTH OF RETURNED DDNAME
STH R0,@OFILE STORE IN LENGTH PREFIX FOR FILE
LA R1,S99 ADDRESS OF WORK AREA
DALLOC DALRTDDN,$OFILE
DALLOC DALDSNAM,$ODS
DALLOC DALPASSW,$OPASS
DALLOC DALSTATS,OLD
DALLOC
LR R3,R1 ADDRESS OF SVC 99 REQUEST BLOCK
OI SWITCH,OALLOC SET OALLOC SWITCH
LTR R9,R15 OK ?
BZR R11 ... YES
CH R15,H04 RC 04 ?
BNE PDR0830 ... NO
CLC S99ERROR-S99RB(2,R3),RC1708 NOT CATALOGED ?
BE PDR0840 ... YES -> ALLOCATE NEW DATASET
PDR0830 DS 0H
BAL R4,PDR2300 <----------> INVOKE DAIRFAIL ROUTINE
BR R11 ... AND EXIT
PREFMOV2 MVC $ODS(*-*),PREFIX STATEMENT WILL BE EXECUTED
***********************************************************************
* ALLOCATE NEW OUTDATASET USING SVC 99 *
***********************************************************************
PDR0840 DS 0H
LA R1,MSG18 'ALLOCATING NEW OUTPUT DATASET'
BAL R3,PDR1900 <----------> WRITE MESSAGE
LA R0,8 LENGTH OF RETURNED DDNAME
STH R0,@OFILE STORE IN LENGTH PREFIX FOR FILE
LA R1,S99 ADDRESS OF WORK AREA
DALLOC DALRTDDN,$OFILE
DALLOC DALDSNAM,$ODS
DALLOC DALTRK
DALLOC DALPRIME,$PRIME
DALLOC DALDIR,$DIRBLK
DALLOC DALSTATS,NEW
DALLOC DALNDISP,CATLG
DALLOC
LR R3,R1 ADDRESS OF SVC 99 REQUEST BLOCK
OI SWITCH,OALLOC SET OALLOC SWITCH
LTR R9,R15 OK ?
BZR R11 ... YES
BAL R4,PDR2300 <----------> INVOKE DAIRFAIL ROUTINE
BR R11 ... AND EXIT
EJECT
***********************************************************************
* PROCESS OUTFILE/OFILE KEYWORDS *
***********************************************************************
PDR0850 DS 0H
L R1,OFILE2-PDL(,R8) POINTER TO OFILE2 PARAMETER
MVI $OFILE,C' ' CLEAR
MVC $OFILE+1(7),$OFILE OUTPUT BUFFER
LH R15,OFILE2+4-PDL(,R8) LENGTH OF OFILE2 PARAMETER
STH R15,@OFILE STORE LENGTH
BCTR R15,0 DECREMENT FOR USE WITH EXECUTE
LA R14,$OFILE ADDRESS OF TARGET LOCATION
EX R15,COPYVAR COPY PDL PARAMETER TO TARGET
SLR R9,R9 SET GOOD RETURN
BR R11 RETURN
TITLE 'P D R E S T - PDR0900'
***********************************************************************
* PDR0900 *
***********************************************************************
PDR0900 DS 0H
*
* THIS ROUTINE CHECKS ATTRIBUTES OF OUTPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
MVC READDCB+DCBDDNAM-IHADCB(8),$OFILE INSERT DDNAME
LA R0,JFCB ADDR OF WORKAREA
STCM R0,B'0111',JFCBADDR SAVE IT IN EXIT LIST
LA R0,EXLIST ADDR OF EXIT LIST
STCM R0,B'0111',READDCB+DCBEXLSA-IHADCB SAVE IT IN DCB
RDJFCB READDCB,MF=(E,RDJFCBL) READ JFCB FOR SPECIFIED DDNAME
LTR R15,R15 OK ?
BZ PDR0910 ... YES
LA R9,8 SET ERROR CODE
CH R15,H04 RC 04 ?
BNER R11 ... NO, ABEND
MVC MSG19+18(8),$OFILE INSERT DDNAME IN MESSAGE
LA R1,MSG19 'DDNAME -------- IS MISSING'
BAL R3,PDR1900 <----------> WRITE MESSAGE
LA R9,4 SET ERROR CODE
BR R11 ... AND EXIT
PDR0910 DS 0H
OBTAIN OBTLIST READ DSCB FOR DSN IN JFCB
LTR R15,R15 OK ?
BZ PDR0920 ... YES
LA R9,8 SET ERROR CODE
CH R15,H08 RC 08 ?
BNER R11 ... NO, ABEND
MVC MSG20+43(6),JFCBVOLS INSERT VOLSER IN MESSAGE
LA R1,MSG22 'OUTPUT DS ... NOT ON VOLUME'
BAL R3,PDR1900 <----------> WRITE MESSAGE
LA R9,4 SET ERROR CODE
BR R11 ... AND EXIT
PDR0920 DS 0H
SR R9,R9 SET RETURN CODE ZERO
CLC DS1DSORG(2),DSORGPO DSORG PO ?
BER R11 ... YES
LA R1,MSG23 'OUTPUT DS ... NOT PARTITIONED'
BAL R3,PDR1900 <----------> WRITE MESSAGE
LA R9,4 SET ERROR CODE
BR R11 ... AND EXIT
TITLE 'P D R E S T - PDR1000'
***********************************************************************
* PDR1000 *
***********************************************************************
PDR1000 DS 0H
*
* THIS ROUTINE OPENS OUTPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
SR R9,R9 SET GOOD RETURN CODE
MVC OUT+DCBDDNAM-IHADCB(8),$OFILE INSERT DDNAME
OPEN (OUT,(OUTPUT)),MF=(E,OPENLST3)
TM OUT+DCBOFLGS-IHADCB,DCBOFOPN OUTPUT DS OPEN OK ?
BOR R11 ... YES, GO ON
MVC MSG12+40(8),$OFILE INSERT DDNAME
LA R1,MSG12 'UNSUCCESSFUL OPEN ...'
BAL R3,PDR1900 <----------------> WRITE MESSAGE
LA R9,4 SET BAD RETURN CODE
BR R11 ... AND EXIT
TITLE 'P D R E S T - PDR1100'
***********************************************************************
* PDR1100 *
***********************************************************************
PDR1100 DS 0H
*
* THIS ROUTINE COPIES INPUT DATASET TO OUTPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK + LINKAGE REGISTER
* R3 - WORK
* R4 - BASE FOR DIRENTRY
* R7 - WORK
* R8 - WORK
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
L R2,RECADDR ADDR OF BUFFER
LA R3,IN ADDR OF DCB
L R7,MAXSIZE MAXIMUM TRACK SIZE
READ DECBIN,SF,(R3),(R2),(R7),MF=E READ A DATA BLOCK
CHECK DECBIN CHECK IF I/O OK
LH R0,DECBIN+6 REQUESTED LENGTH (MAXSIZE)
L R1,DECBIN+16 IOB ADDR
SH R0,14(,R1) SUBTRACT RESIDUAL COUNT
STH R0,RECSIZE SAVE SIZE OF RECORD JUST READ
LA R9,32 ASSUME ERROR
LA R1,IN ADDR OF DCB
BAL R2,PDR2000 <----------> WR. 'TTR OF LAST BLOCK READ ...'
LTR R0,R9 OK ?
BNZ PDR1175 ... NO
SR R9,R9 ASSUME OK
TM FLAGS,FIRST FIRST BLOCK IN FILE ?
BZ PDR1130 ... NO
*
NI FLAGS,X'FF'-FIRST RESET FIRST SWITCH
NI FLAGS,X'FF'-SKIPMEM MEMBER IS NOT TO BE SKIPPED
NI FLAGS,X'FF'-PTRFLAG MEMBER DOES NOT CONTAIN PTRS
NI FLAGS,X'FF'-DEADMEM MEMBER IS NOT 'DEAD'
NOTE IN TTR OF LAST BLOCK READ
ST R1,MEMTTRX RETURNED IN REGISTER 1
LH R3,COUNT PREVIOUS MEMBER NUMBER
LA R3,1(R3) MEMBER NUMBER
STH R3,COUNT UPDATE COUNT
CVD R3,PACK CONVERT TO PACKED DECIMAL
UNPK GMEMBER+4(4),PACK(8) CONVERT TO ZONED
OI GMEMBER+7,X'F0' SET ZONE IN SIGN BYTE
L R4,TABLADDR ADDR OF TABLE START
USING DIRENTRY,R4 ADDRESSABILITY
PDR1105 DS 0H
CLC LINK(4),F00
BE PDR1110 ... YES
MVC TTRSAVE(4),MEMTTR MOVE TTR-ENTRY TO WORK AREA
NI TTRSAVE+3,B'10000000' REMOVE ALL BUT ALIAS INDICATOR
CLC MEMTTRX(4),TTRSAVE TTR EQUAL AND NOT ALIAS ?
BE PDR1115 ... YES
L R4,LINK UPDATE USING
B PDR1105 TRY NEXT IN TABLE
PDR1110 DS 0H
MVC MSG04+11(8),GMEMBER MOVE TO WTO MESSAGE
OI FLAGS,DEADMEM INDICATE 'DEAD' MEMBER
TM FLAGS,DEBUGOPT DEBUG OPTION IN EFFECT ?
BNO PDR1130 ... NO
LA R1,MSG16 'DEAD MEMBER'
BAL R3,PDR1900 <----------> WRITE MESSAGE
B PDR1130 EXIT
PDR1115 DS 0H
MVC MSG04+11(8),MEMBER MOVE TO WTO MESSAGE
TM FLAGS,DEBUGOPT DEBUG OPTION IN EFFECT ?
BNO PDR1117 ... NO
MVC MSG17+26(8),MEMBER MOVE TO WTO MESSAGE
LA R1,MSG17 'MEMBER NAME IS XXXXXXXX'
BAL R3,PDR1900 <----------> WRITE MESSAGE
PDR1117 DS 0H
TM FLAGS,COPYALL ALL MEMBERS TO BE STOWED ?
BO PDR1120 ... YES
OI FLAGS,SKIPMEM MEMBER IS TO BE SKIPPED
B PDR1130 EXIT
PDR1120 DS 0H
SR R1,R1 R1 := 0
IC R1,USEROPT N IN TTRN
N R1,ANDMASK ZERO IF NO PTRS IN USER DATA
BNZ PDR1125 IF ANY, SKIP STOW
NI FLAGS,X'FF'-SKIPMEM MEMBER IS TO BE COPIED
NI FLAGS,X'FF'-DEADMEM MEMBER IS NOT 'DEAD'
B PDR1130 EXIT
PDR1125 DS 0H
OI FLAGS,SKIPMEM MEMBER IS TO BE SKIPPED
OI FLAGS,PTRFLAG MEMBER CONTAINS POINTERS
SPACE 4
PDR1130 DS 0H
TM FLAGS,SKIPMEM IS MEMBER TO BE SKIPPED ?
BNZ PDR1100 ... YES
L R2,RECADDR ADDR OF BUFFER
LA R3,OUT ADDR OF DCB
LH R7,RECSIZE GET SIZE OF RECORD LAST READ
WRITE DECBOUT,SF,(R3),(R2),(R7),MF=E WRITE A DATA BLOCK
CHECK DECBOUT CHECK IF I/O OK
LA R9,32 ASSUME ERROR
LA R1,OUT ADDR OF DCB
BAL R2,PDR2100 <----------> WR. 'TTR OF LAST BLOCK WRT ...'
LTR R0,R9 OK ?
BNZ PDR1175 ... NO
SR R9,R9 ASSUME OK
B PDR1100 LOOP UNTIL EOF
***********************************************************************
* E O F P R O C E S S I N G F O R D A T A P A R T *
***********************************************************************
PDR1135 DS 0H
XC RECSIZE(2),RECSIZE LENGTH ZERO FOR EOF
LA R1,IN ADDR OF DCB
MVC MSG13+18(4),TEOF WE NOW READ EOF
BAL R2,PDR2000 <----------> WR. 'TTR OF LAST BLOCK READ ...'
MVC MSG13+18(4),TDATA WE NOW READ DATA
LTR R0,R9 OK ?
BNZ PDR1175 ... NO
SR R9,R9 ASSUME OK
OI FLAGS,FIRST SET FIRST SWITCH
TM FLAGS,SKIPMEM IS MEMBER TO BE SKIPPED ?
BNO PDR1145 ... NO
TM FLAGS,PTRFLAG DOES MEMBER CONTAIN PTRS ?
BNO PDR1170 ... NO, GET NEXT MEMBER
MVC MSG06+11(8),MEMBER MOVE TO WTO MESSAGE
LA R1,MSG06 '... NOT COPIED...CONTAINS PTRS'
BAL R3,PDR1900 <----------> WRITE MESSAGE
B PDR1170 GET NEXT MEMBER
PDR1145 DS 0H
OI FLAGS,SKIPMEM RESET SWITCH
TM FLAGS,DEADMEM IS MEMBER 'DEAD' ?
BNO PDR1150 ... NO
MVC STOWLIST(12),GMEMBER STOW GENERATED NAME
B PDR1160 GO AND DO IT
PDR1150 DS 0H
SR R6,R6 R6 := 0
LA R8,12 LENGTH OF ENTRY WITH NO USERDATA
IC R6,USEROPT SPECIAL FLAGS
N R6,USERNUM NUMBER OF USER DATA HALFWORDS
BZ PDR1155 ... NONE
AR R8,R6 LENGTH OF
AR R8,R6 COMPLETE ENTRY (R6 HALFWORDS)
PDR1155 DS 0H
BCTR R8,0 DECREMENT FOR USE WITH EXECUTE
EX R8,MOVEMEM2 INSERT MEMBER NAME IN STOW LIST
XC STOWLIST+8(3),STOWLIST+8 ZERO TTR FIELD
PDR1160 DS 0H
BAL R2,PDR2200 <----------> ISSUE STOW
CH R9,H04 RETURN CODE > 4 ?
BH PDR1175 ... YES
BE PDR1170 RETURN CODE 4
*
LA R9,32 ASSUME ERROR
LA R1,OUT ADDR OF DCB
XC RECSIZE(2),RECSIZE LENGTH ZERO FOR EOF
MVC MSG01+18(4),TEOF WE NOW WRITE EOF
BAL R2,PDR2100 <----------> WR. 'TTR OF LAST BLOCK WRT ...'
MVC MSG01+18(4),TDATA WE NOW WRITE DATA
LTR R0,R9 OK ?
BNZ PDR1175 ... NO
SR R9,R9 ASSUME OK
LA R1,MSG04 '... HAS BEEN COPIED/REPLACED'
BAL R3,PDR1900 <----------> WRITE MESSAGE
*
PDR1170 DS 0H
NOTE IN TTR OF EOF MARK
ST R1,POINTTTR RETURNED IN REGISTER 1
MVI POINTTTR+3,X'01' TTR OF FIRST BLOCK AFTER EOF
C R1,LASTIN EQUAL TO LAST BLOCK PTR ?
BE PDR1175 ... YES -> CLOSE OUTPUT DATASET
POINT IN,POINTTTR NEXT READ AT THAT TTR
B PDR1100 GET NEXT MEMBER
PDR1175 DS 0H
CLOSE OUT,MF=(E,CLOSLIST) CLOSE OUTPUT DATASET
BR R11 RETURN
MOVEMEM2 MVC STOWLIST(*-*),MEMBER WILL BE EXECUTED
DROP R4
TITLE 'P D R E S T - PDR1200'
***********************************************************************
* PDR1200 *
***********************************************************************
PDR1200 DS 0H
*
* THIS ROUTINE COPIES RECFM, LRECL AND BLKSIZE FROM INPUT DATASET TO
* OUTPUT DATASET.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
LA R0,PDR1800 ADDR OF DCB OPEN EXIT
STCM R0,B'0111',DCBMODA SAVE IT IN EXIT LIST
LA R0,EXLIST2 ADDR OF EXIT LIST
STCM R0,B'0111',OUT+DCBEXLSA-IHADCB SAVE IT IN DCB
OPEN (OUT,(OUTPUT)),MF=(E,OPENLST3) SET DCB VIA DCB OPEN EXIT
CLOSE OUT,MF=(E,CLOSLIST) CLOSE IT AGAIN
BR R11 RETURN
TITLE 'P D R E S T - PDR1400'
***********************************************************************
* PDR1400 *
***********************************************************************
PDR1400 DS 0H
*
* THIS ROUTINE ISSUES AN ABEND.
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R3 - LINKAGE REGISTER
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R14 - WORK
* R15 - WORK
*
LA R1,MSG24 'INTERNAL ERROR IN PDREST'
BAL R3,PDR1900 <----------> WRITE MESSAGE
ABEND 100,DUMP
TITLE 'P D R E S T - PDR1500'
***********************************************************************
* PDR1500 *
***********************************************************************
PDR1500 DS 0H
*
* THIS ROUTINE WILL FREE OUTPUT DATASET, IF ALLOCATED
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - WORK
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
TM SWITCH,OALLOC OUTPUT DATASET ALLOCATED ?
BNO 0(R11) ... NO
LA R1,S99 ADDRESS OF WORK AREA
DALLOC DUNDDNAM,$OFILE
DALLOC DUNUNALC
DALLOC
LR R3,R1 ADDRESS OF SVC 99 REQUEST BLOCK
LTR R9,R15 OK ?
BZR R11 ... YES
BAL R4,PDR2300 <----------> INVOKE DAIRFAIL ROUTINE
BR R11 ... RETURN
TITLE 'P D R E S T - PDR1600'
***********************************************************************
* PDR1600 *
***********************************************************************
PDR1600 DS 0H
*
* THIS ROUTINE WILL FREE INPUT DATASET, IF ALLOCATED
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - WORK
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
TM SWITCH,IALLOC INPUT DATASET ALLOCATED ?
BNO 0(R11) ... NO
LA R1,S99 ADDRESS OF WORK AREA
DALLOC DUNDDNAM,$IFILE
DALLOC DUNUNALC
DALLOC
LR R3,R1 ADDRESS OF SVC 99 REQUEST BLOCK
LTR R9,R15 OK ?
BZR R11 ... YES
BAL R4,PDR2300 <----------> INVOKE DAIRFAIL ROUTINE
BR R11 ... RETURN
TITLE 'P D R E S T - PDR1700'
***********************************************************************
* PDR1700 *
***********************************************************************
PDR1700 DS 0H
*
* THIS ROUTINE WILL FREE PDL GETMAINED BY IKJPARS
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R10 - BASE REGISTER
* R11 - LINKAGE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
IKJRLSA PDLADDR FREE PDL STORAGE
BR R11 ... RETURN
TITLE 'P D R E S T - PDR1800'
***********************************************************************
* PDR1800 *
***********************************************************************
PDR1800 DS 0H
*
* THIS ROUTINE IS A DCB OPEN EXIT (CALLED VIA DCB EXLST FACILITY).
*
* REGISTER ASSIGNMENT:
*
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - LINKAGE REGISTER
*
MVC OUT+DCBLRECL-IHADCB(2),INLRECL INSERT LRECL
MVC OUT+DCBBLKSI-IHADCB(2),INBLOCK INSERT BLKSIZE
MVC OUT+DCBRECFM-IHADCB(1),INRECFM INSERT RECFM
BR R14 RETURN TO OPEN
TITLE 'P D R E S T - PDR1900'
***********************************************************************
* PDR1900 *
***********************************************************************
PDR1900 DS 0H
*
* THIS ROUTINE WILL WRITE A MESSAGE (80 BYTES)
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - ADDRESS OF MESSAGE TO BE WRITTEN
* R3 - LINKAGE REGISTER
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
LA R0,1 1 SEGMENT
ST R0,OLD SAVE IN OLD
LA R0,PUTLMSG ADDR OF SEGMENT
ST R0,OLD+4 SAVE IN OLD
LA R0,84 LENGTH OF SEGMENT
STH R0,PUTLMSG SAVE IN SEGMENT PREFIX
SLR R0,R0 OFFSET ZERO
STH R0,PUTLMSG+2 SAVE OFFSET
MVC PUTLMSG+4(80),0(R1) MOVE MESSAGE TO SEGMENT
XC ECB(4),ECB CLEAR ECB
PUTLINE PARM=PUTLINEL,OUTPUT=(OLD,TERM,SINGLE,INFOR), *
MF=(E,IOPLAREA)
BR R3 RETURN
TITLE 'P D R E S T - PDR2000'
***********************************************************************
* PDR2000 *
***********************************************************************
PDR2000 DS 0H
*
* THIS ROUTINE WILL WRITE 'TTR OF LAST RECORD READ ...'
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - ADDR OF DCB
* R2 - LINKAGE REGISTER
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE SHARED WITH PDR2400
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
SR R9,R9 SET OK RETURN CODE
TM FLAGS,DEBUGOPT DEBUG OPTION IN EFFECT ?
BNO 0(R2) ... NO
BAL R3,PDR2400 <----------> GET TTR AND CCHHR OF CURR. POS.
MVC MSG13+29(6),HEXTTR MOVE TTR TO MESSAGE
MVC MSG13+43(10),HEXCCHHR MOVE CCHHR TO MESSAGE
LH R1,RECSIZE SIZE OF RECORD READ
CVD R1,PACK CONVERT TO PACKED DECIMAL
UNPK MSG13+62(5),PACK(8) CONVERT TO ZONED
OI MSG13+66,X'F0' MAKE LAST DIGIT LOOK NICE
LA R1,MSG13 'TTR OF LAST BLOCK READ ...'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
TITLE 'P D R E S T - PDR2100'
***********************************************************************
* PDR2100 *
***********************************************************************
PDR2100 DS 0H
*
* THIS ROUTINE WILL WRITE 'TTR OF LAST RECORD WRITTEN ...'
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - ADDR OF DCB
* R2 - LINKAGE REGISTER
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE SHARED WITH PDR2400
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
SR R9,R9 SET OK RETURN CODE
TM FLAGS,DEBUGOPT DEBUG OPTION IN EFFECT ?
BNO 0(R2) ... NO
BAL R3,PDR2400 <----------> GET TTR AND CCHHR OF CURR. POS.
MVC MSG01+29(6),HEXTTR MOVE TTR TO MESSAGE
MVC MSG01+43(10),HEXCCHHR MOVE CCHHR TO MESSAGE
LH R1,RECSIZE SIZE OF RECORD READ
CVD R1,PACK CONVERT TO PACKED DECIMAL
UNPK MSG01+62(5),PACK(8) CONVERT TO ZONED
OI MSG01+66,X'F0' MAKE LAST DIGIT LOOK NICE
LA R1,MSG01 'TTR OF LAST BLOCK WRITTEN ...'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
TITLE 'P D R E S T - PDR2200'
***********************************************************************
* PDR2200 *
***********************************************************************
PDR2200 DS 0H
*
* THIS ROUTINE ISSUES STOW AND HANDLES STOW ERRORS
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - LINKAGE REGISTER
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
TM FLAGS,REPLOPT REPLACE OPTION IN EFFECT ?
BZ PDR2210 ... NO
STOW OUT,STOWLIST,R ISSUE STOW
LR R9,R15 OK ?
CH R9,H24 RETURN CODE TOO HIGH ?
BH PDR1400 ... YES, GO ABEND
B *+4(R9) ENTER BRANCH TABLE 0 <= RC <= 24
B PDR2230 00: MEMBER REPLACED IN DATASET
B PDR1400 04: WON'T HAPPEN
B PDR2220 08: MEMBER ADDED TO DATASET
B PDR2250 12: NO SPACE LEFT IN DIRECTORY
B PDR2260 16: STOW INPUT/OUTPUT ERROR
B PDR2270 20: DCB IS OPENED INCORRECTLY
B PDR2280 24: INSUFF. STG. FOR STOW GETM.
PDR2210 DS 0H
STOW OUT,STOWLIST,A ISSUE STOW
LR R9,R15 OK ?
CH R9,H24 RETURN CODE TOO HIGH ?
BH PDR1400 ... YES, GO ABEND
B *+4(R9) ENTER BRANCH TABLE 0 <= RC <= 24
B PDR2220 00: MEMBER ADDED TO DATASET
B PDR2240 04: MEMBER ALREADY IN DIRECTORY
B PDR1400 08: WON'T HAPPEN
B PDR2250 12: NO SPACE LEFT IN DIRECTORY
B PDR2260 16: STOW INPUT/OUTPUT ERROR
B PDR2270 20: DCB IS OPENED INCORRECTLY
B PDR2280 24: INSUFF. STG. FOR STOW GETM.
*
PDR2220 DS 0H
MVC MSG04+29(8),TCOPIED INDICATE 'COPIED'
SLR R9,R9 RETURNCODE ZERO
BR R2 RETURN
PDR2230 DS 0H
MVC MSG04+29(8),TREPL INDICATE 'REPLACED'
SLR R9,R9 RETURNCODE ZERO
BR R2 RETURN
PDR2240 DS 0H
MVC MSG07+11(8),MSG04+11 INSERT THE MEMBERNAME
LA R1,MSG07 '... EXISTS IN DIRECTORY'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
PDR2250 DS 0H
LA R1,MSG08 'NO SPACE LEFT IN DIRECTORY'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
PDR2260 DS 0H
LA R1,MSG09 'STOW I/O ERROR'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
PDR2270 DS 0H
LA R1,MSG10 'DCB IS OPENED INCORRECTLY ...'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
PDR2280 DS 0H
LA R1,MSG11 'INSUFF. STORAGE FOR GETMAIN'
BAL R3,PDR1900 <----------> WRITE MESSAGE
BR R2 RETURN
TITLE 'P D R E S T - PDR2300'
***********************************************************************
* PDR2300 *
***********************************************************************
PDR2300 DS 0H
*
* THIS ROUTINE INVOKES DAIRFAIL ROUTINE
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - WORK
* R2 - WORK
* R3 - AT ENTRY: ADDRESS OF DYNALLOC REQUEST BLOCK
* R4 - LINKAGE REGISTER
* R9 - RETURN CODE SHARED WITH CALLING ROUTING
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - AT ENTRY: RETURN CODE FROM DYNALLOC
*
LA R9,4 SET BAD RETURN CODE
ST R15,REG15SAV SAVE RETURN CODE
L R2,CPPLADDR ADDR OF CPPL
LINK EP=IKJEFF18,MF=(E,DFPARMS), D A I R F A I L *
PARAM=((3),REG15SAV,F00,DFAILSW,(2))
LTR R15,R15 OK ?
BZR R4 ... RETURN
LA R9,8 SET BAD RETURN CODE
BR R4 ... RETURN
TITLE 'P D R E S T - PDR2400'
***********************************************************************
* PDR2400 *
***********************************************************************
PDR2400 DS 0H
*
* THIS ROUTINE CONVERTS TTR ADDRESSES TO CCHHR ADDRESSES
*
* REGISTER ASSIGNMENT:
*
* R0 - WORK
* R1 - ADDRESS OF DCB
* R2 - WORK (+ LINKAGE REGISTER IN CALLING ROUTINE)
* R3 - LINKAGE REGISTER
* R9 - RETURN CODE SHARED WITH CALLING ROUTING
* R10 - BASE REGISTER
* R12 - BASE REGISTER
* R13 - SAVE AREA + DYNAMIC STORAGE
* R14 - WORK
* R15 - WORK
*
LR R9,R1 SAVE DCB ADDRESS
NOTE (1) GET TTR OF CURRENT POSITION
STM R2,R12,28(R13) SAVE REGISTERS
LR R3,R13 SAVE R13
ST R1,WORK1 SAVE TTRN IN WORK AREA
UNPK WORK2(9),WORK1(5) CHG X'0'-X'F' -> X'F0'-X'FF'
TR WORK2(8),TRTAB CHG X'F0'-X'FF' -> C'0'-C'F'
MVC HEXTTR(6),WORK2 MOVE TO ANSWER AREA
LR R0,R1 TTRN NOW IN R0
L R1,DCBDEBAD-IHADCB(,R9) DEB ADDRESS NOW IN R1
LA R2,MBBCCHHR ADDRESS OF ANSWER AREA
L R15,CVTPTR ADDRESS OF CVT
L R15,CVTPCNVT-CVT(,R15) ADDRESS OF CONVERSION ROUTINE
BALR R14,R15 CALL CONVERSION ROUTINE
LR R13,R3 RESTORE R13
LM R2,R12,28(R13) RESTORE REGISTERS
LTR R9,R15 OK ?
BNZ 0(R3) ... NO
MVC WORK1(4),MBBCCHHR+3 MOVE TO WORK AREA
UNPK WORK2(9),WORK1(5) CHG X'0'-X'F' -> X'F0'-X'FF'
TR WORK2(8),TRTAB CHG X'F0'-X'FF' -> C'0'-C'F'
MVC HEXCCHHR(8),WORK2 MOVE TO ANSWER AREA
XC WORK1(4),WORK1 CLEAR WORK AREA
MVC WORK1(1),MBBCCHHR+7 MOVE TO WORK AREA
UNPK WORK2(9),WORK1(5) CHG X'0'-X'F' -> X'F0'-X'FF'
TR WORK2(8),TRTAB CHG X'F0'-X'FF' -> C'0'-C'F'
MVC HEXCCHHR+8(2),WORK2 MOVE TO ANSWER AREA
BR R3 ... RETURN
TITLE 'P D R E S T - CONSTANTS'
***********************************************************************
* CONSTANTS *
***********************************************************************
TCOPIED DC CL8'COPIED'
TDATA DC CL4'DATA'
TEOF DC CL4'EOF '
TREPL DC CL8'REPLACED'
DSORGPO DC B'00000010',X'00' CODE FOR DSORG = PO
H03 DC H'03' CONSTANT
H04 DC H'4' CONSTANT
F01 DC F'1' CONSTANT
F02 DC F'2' CONSTANT
F03 DC F'3' CONSTANT
F04 DC F'4' CONSTANT
H08 DC H'8' CONSTANT
H24 DC H'24' CONSTANT
F00 DC F'0' CONSTANT
RC1708 DC X'1708' S99ERROR CODE = NOT CATALOGED
DFAILSW DC X'0032' SWITCHES USED TO CALL DAIRFAIL
DIRMIN DC F'1024' MIN BYTES FOR GETMAIN
DIRMAX DC F'8388608' MAX BYTES FOR GETMAIN = 8M
ENDMARK DC 8X'FF' ENDMARK IN DIRECTORY
USERNUM DC XL4'0000001F' CONSTANT
ANDMASK DC XL4'00000060' CONSTANT
MSG08 DC CL80'PDREST-08: NO SPACE LEFT IN DIRECTORY'
MSG09 DC CL80'PDREST-09: STOW I/O ERROR'
MSG10 DC CL80'PDREST-10: THE DCB IS OPENED INCORRECTLY FOR STOW'
MSG11 DC CL80'PDREST-11: INSUFFICIENT STORAGE FOR STOW GETMAIN'
MSG16 DC CL80'PDREST-16: MEMBER IS DEAD'
MSG18 DC CL80'PDREST-18: ALLOCATING NEW OUTPUT DATASET'
MSG21 DC CL80'PDREST-21: INPUT DATASET IS NOT PARTITIONED'
MSG23 DC CL80'PDREST-23: OUTPUT DATASET IS NOT PARTITIONED'
MSG24 DC CL80'PDREST-24: INTERNAL ERROR IN PDREST'
MSG25 DC CL80'PDREST-25: NOT ENOUGH SPACE FOR IN STORAGE DIRECTOR*
Y. INCREASE REGION SIZE'
DSNMOVE MVC 1(*-*,R2),WDATASET STATEMENT WILL BE EXECUTED
COPYVAR MVC 0(*-*,R14),0(R1) MOVE PDL PARM TO FIXED STRING
TITLE 'P D R E S T - DATA AREAS'
***********************************************************************
* DATA AREAS *
***********************************************************************
LTORG
INIT DS 0D
PRINT NOGEN
DCB DDNAME=*-*,DSORG=PO,MACRF=R,EODAD=PDR0750,RECFM=U
DCB DDNAME=*-*,DSORG=PO,MACRF=W,RECFM=U,EXLST=*-*
DC 0F'0',X'85'
DC AL3(*-*)
DCB DDNAME=*-*,DSORG=PO,MACRF=E,EXLST=*-*
PRINT GEN
DC 0F'0',X'87'
DC AL3(*-*)
CAMLST SEARCH,*-*,*-*,*-*
OPEN (*-*,(INPUT)),MF=L
OPEN (*-*,(OUTPUT)),MF=L
CLOSE (*-*),MF=L CLOSE DATASET
READ DECBNO1,SF,*-*,*-*,*-*,MF=L CREATE DECB
WRITE DECBNO2,SF,*-*,*-*,*-*,MF=L CREATE DECB
RDJFCB (*-*),MF=L RDJFCB LIST
GETMAIN VU,LA=*-*,A=*-*,MF=L
FREEMAIN VU,A=*-*,MF=L
PUTLINE MF=L PUTLINE PARAMETER BLOCK
DC CL80'PDREST-01: WRITE (DATA): TTR=TTTTRR, CCHHR=CCCCHHHH*
RR, LENGTH=LLLLL'
DC CL80'PDREST-04: -------- HAS BEEN --------'
DC CL80'PDREST-06: -------- HAS NOT BEEN COPIED, BECAUSE US*
ERDATA CONTAINS POINTERS'
DC CL80'PDREST-07: -------- ALREADY EXISTS IN DIRECTORY AND*
IS NOT REPLACED'
DC CL80'PDREST-12: UNSUCCESSFUL OPEN FOR DDNAME --------'
DC CL80'PDREST-13: READ (DIR.): TTR=TTTTRR, CCHHR=CCCCHHHH*
RR, LENGTH=LLLLL'
DC CL80'PDREST-14: EOF (DIR.), XXXX DIRBLKS, XXXXX MEMBER*
S'
DC CL80'PDREST-17: MEMBER NAME IS XXXXXXXX'
DC CL80'PDREST-19: DDNAME -------- IS MISSING'
DC CL80'PDREST-20: INPUT DATASET IS NOT ON VOLUME ------'
DC CL80'PDREST-22: OUTPUT DATASET IS NOT ON VOLUME ------'
DC B'11110000' INITIAL FLAG SETTINGS
DC H'0' MEMBER NUMBER
DC D'0' WORK AREA FOR CONVERSION
DC CL8'PDRV----',AL3(0),AL1(0) STOW LIST
DC 0F'0',4X'00',X'0F' USED IN HEX -> EBCDIC HEX CONV.
DC 9X'00' USED IN HEX -> EBCDIC HEX CONV.
DC CL16'0123456789ABCDEF' TRANSLATE TABLE
DC A(PCL) ADDR OF PCL
DC XL4'FF000000' ADDR OF PDL RETURNED BY PARSE
INITLGTH EQU *-INIT LENGTH TO MOVE
TITLE 'P D R E S T - PDREST PARAMETER CSECT'
***********************************************************************
* PDREST PARAMETER CSECT *
***********************************************************************
PRINT NOGEN
PCL IKJPARM DSECT=PDL
IDS IKJKEYWD DEFAULT='INDATASET'
IKJNAME 'INDATASET',SUBFLD=FLD1
IKJNAME 'IDS',SUBFLD=FLD1
IKJNAME 'INFILE',SUBFLD=FLD2
IKJNAME 'IFILE',SUBFLD=FLD2
ODS IKJKEYWD DEFAULT='OUTDATASET'
IKJNAME 'OUTDATASET',SUBFLD=FLD3
IKJNAME 'ODS',SUBFLD=FLD3
IKJNAME 'OUTFILE',SUBFLD=FLD4
IKJNAME 'OFILE',SUBFLD=FLD4
MODE IKJKEYWD DEFAULT='DELETED'
IKJNAME 'DELETED'
IKJNAME 'ALL'
REPLACE IKJKEYWD DEFAULT='NOREPLACE'
IKJNAME 'REPLACE'
IKJNAME 'NOREPLACE'
DEBUG IKJKEYWD DEFAULT='NODEBUG'
IKJNAME 'DEBUG'
IKJNAME 'NODEBUG'
FLD1 IKJSUBF
IDS2 IKJPOSIT DSNAME,PROMPT='INPUT DATASET NAME', *
HELP='NAME OF INPUT DATASET TO PDREST'
IPASS EQU IDS2+16
FLD2 IKJSUBF
IFILE2 IKJIDENT 'FILE',MAXLNTH=8, *
FIRST=ALPHA,OTHER=ALPHANUM, *
PROMPT='INPUT DDNAME', *
HELP='DDNAME OF INPUT DATASET TO PDREST'
FLD3 IKJSUBF
ODS2 IKJPOSIT DSNAME,PROMPT='OUTPUT DATASET NAME', *
HELP='NAME OF DATASET TO RECEIVE PDREST OUTPUT'
OPASS EQU ODS2+16
FLD4 IKJSUBF
OFILE2 IKJIDENT 'FILE',MAXLNTH=8, *
FIRST=ALPHA,OTHER=ALPHANUM, *
PROMPT='OUTPUT DDNAME', *
HELP='DDNAME OF DATASET TO RECEIVE OUTPUT FROM PDREST'
IKJENDP
PRINT GEN
TITLE 'P D R E S T - WORK DSECT'
***********************************************************************
* WORK DSECT *
***********************************************************************
SAVE DSECT
SAVEAREA DS 20F SAVE AREA
WORK EQU *
PRINT NOGEN
IN DCB DDNAME=*-*,DSORG=PO,MACRF=R,EODAD=PDR0750,RECFM=U
OUT DCB DDNAME=*-*,DSORG=PO,MACRF=W,RECFM=U,EXLST=*-*
EXLIST2 DC 0F'0',X'85'
DCBMODA DC AL3(*-*)
READDCB DCB DDNAME=*-*,DSORG=PO,MACRF=E,EXLST=*-*
PRINT GEN
EXLIST DC 0F'0',X'87'
JFCBADDR DC AL3(*-*)
OBTLIST CAMLST SEARCH,*-*,*-*,*-*
OPENLST2 OPEN (*-*,(INPUT)),MF=L
OPENLST3 OPEN (*-*,(OUTPUT)),MF=L
CLOSLIST CLOSE (*-*),MF=L CLOSE DATASET
READ01 READ DECBIN,SF,*-*,*-*,*-*,MF=L CREATE DECB
WRITE01 WRITE DECBOUT,SF,*-*,*-*,*-*,MF=L CREATE DECB
RDJFCBL RDJFCB (*-*),MF=L RDJFCB LIST
GETMAINL GETMAIN VU,LA=*-*,A=*-*,MF=L
FREEMAIL FREEMAIN VU,A=*-*,MF=L
PUTLINEL PUTLINE MF=L PUTLINE PARAMETER BLOCK
MSG01 DC CL80'PDREST-01: WRITE (DATA): TTR=TTTTRR, CCHHR=CCCCHHHH*
RR, LENGTH=LLLLL'
MSG04 DC CL80'PDREST-04: -------- HAS BEEN --------'
MSG06 DC CL80'PDREST-06: -------- HAS NOT BEEN COPIED, BECAUSE US*
ERDATA CONTAINS POINTERS'
MSG07 DC CL80'PDREST-07: -------- ALREADY EXISTS IN DIRECTORY AND*
IS NOT REPLACED'
MSG12 DC CL80'PDREST-12: UNSUCCESSFUL OPEN FOR DDNAME --------'
MSG13 DC CL80'PDREST-13: READ (DIR.): TTR=TTTTRR, CCHHR=CCCCHHHH*
RR, LENGTH=LLLLL'
MSG14 DC CL80'PDREST-14: EOF (DIR.), XXXX DIRBLKS, XXXXX MEMBER*
S'
MSG17 DC CL80'PDREST-17: MEMBER NAME IS XXXXXXXX'
MSG19 DC CL80'PDREST-19: DDNAME -------- IS MISSING'
MSG20 DC CL80'PDREST-20: INPUT DATASET IS NOT ON VOLUME ------'
MSG22 DC CL80'PDREST-22: OUTPUT DATASET IS NOT ON VOLUME ------'
FLAGS DC B'11110000' INITIAL FLAG SETTINGS
FIRST EQU B'10000000' INDICATES FIRST BLOCK IN FILE
DIR EQU B'01000000' INDICATES DIRECTORY FILE
COPYALL EQU B'00100000' ALL MEMBERS WILL BE COPIED
SKIPMEM EQU B'00010000' THIS MEMBER IS TO BE SKIPPED
PTRFLAG EQU B'00001000' MEMBER CONTAINS POINTERS
DEADMEM EQU B'00000100' MEMBER IS 'DEAD'
DEBUGOPT EQU B'00000010' DEBUG OPTION IS IN EFFECT
REPLOPT EQU B'00000001' REPLACE OPTION IS IN EFFECT
COUNT DC H'0' MEMBER NUMBER
PACK DC D'0' WORK AREA FOR CONVERSION
GMEMBER DC CL8'PDRV----',AL3(0),AL1(0) STOW LIST
WORK1 DC 0F'0',4X'00',X'0F' USED IN HEX -> EBCDIC HEX CONV.
WORK2 DC 9X'00' USED IN HEX -> EBCDIC HEX CONV.
ORG *-240
TRTAB EQU *
ORG
DC CL16'0123456789ABCDEF' TRANSLATE TABLE
PCLADDR DC A(PCL) ADDR OF PCL
PDLADDR DC XL4'FF000000' ADDR OF PDL RETURNED BY PARSE
INITLG2 EQU *-WORK SHOULD EQUATE TO INITLGTH
DS 0F
TTRSAVE DS 4X SAVE FOR TTR AND WORKAREA
LASTIN DS 4X LAST BLOCK POINTER FOR INPUT DSN
POINTTTR DS 4X SAVE FOR TTRZ TO USE WITH POINT
CL DS 6A CALL LIST
INLRECL DS H LRECL FOR INPUT DSN (FROM DSCB)
INBLOCK DS H BLKSIZE FOR INPUT DSN (FROM DSCB)
INRECFM DS X RECFM FOR INPUT DSN (FROM DSCB)
MEMTTRX DS F TTR0 OF CURRENT MEMBER
STOWLIST DS 74C MAXIMUM SIZE OF STOW LIST
PPLAREA DS 7F PARSE PARAMETER LIST
IOPLAREA DS 4F INPUT/OUTPUT PARAMETER BLOCK
OLD DS 2F OUTPUT LINE DESCRIPTOR
PUTLMSG DS CL84 PUTLINE MESSAGE SEGMENT
UWA DS F USER WORK AREA (NOT USED)
ECB DS F ECB TO BE POSTED IN PARSE
PREFIX DS CL8 USERID PREFIX (7 BYTES) + LENGTH
@IDS DS H LENGTH OF $IDS STRING
$IDS DS CL44 DATASET STRING (MAX 44 BYTES)
@IPASS DS H LENGTH OF $IPASS STRING
$IPASS DS CL8 PASSWORD STRING (MAX 8 BYTES)
@IFILE DS H LENGTH OF $IFILE STRING
$IFILE DS CL8 FILE STRING (MAX 8 BYTES)
@ODS DS H LENGTH OF $ODS STRING
$ODS DS CL44 DATASET STRING (MAX 44 BYTES)
@OPASS DS H LENGTH OF $IPASS STRING
$OPASS DS CL8 PASSWORD STRING (MAX 8 BYTES)
@OFILE DS H LENGTH OF $IFILE STRING
$OFILE DS CL8 FILE STRING (MAX 8 BYTES)
@PRIME DS H LENGTH OF $PRIME
$PRIME DS XL3 PRIMARY ALLOCATION
@DIRBLK DS H LENGTH OF $DIRBLK
$DIRBLK DS XL3 NUMBER OF DIRECTORY BLOCKS
WDATASET DS CL44 WORK STRING
REG15SAV DS F SAVE FOR RETURN CODES
S99 DS XL200 SVC 99 PARAMETER BLOCKS
SWITCH DS X SWITCHES
IALLOC EQU X'80' IALLOC SWITCH
OALLOC EQU X'40' OALLOC SWITCH
DIRHIGHA DS F ADDR FOLLOWING DIRECTORY STG.
DIRBLKN DS F NUMBER OF DIRECTORY BLOCKS
MEMBERN DS F NUMBER OF MEMBERS IN DIRECTORY
DIRBLKE DS F ADDR AFTER VALID DATA IN DIRBLK
TABLADDR DS A STARTING ADDR OF TABLE
DIRSPACE DS F BYTES FOR DIRECTORY SPACE
CPPLADDR DS A ADDR OF CPPL
MAXSIZE DS F MAXIMUM RECORD SIZE
DEVAREA DS 5F AREA RETURNED FROM DEVTYPE MACRO
RECADDR DS A ADDRESS OF GETMAINED RECORD AREA
RECSIZE DS H SIZE OF RECORD LAST READ
MBBCCHHR DS CL8 CCHHR ADDRESS FROM CONV. ROUTINE
HEXTTR DS CL6 TTR IN EBCDIC HEX
HEXCCHHR DS CL10 CCHHR IN EBCDIC HEX
IKJEFFDF
IECSDSL1 1 DEFINITION OF FORMAT-1 DSCB
OBTAINWA EQU IECSDSL1+44 OBTAIN DOES NOT RETURN DSNAME
DS 44X ... BUT STILL REQUIRES 140 BYTES
JFCB DS 0F
IEFJFCBN
LWORK EQU *-SAVE LENGTH OF WORK AREA TO GETMAIN
TITLE 'P D R E S T - OTHER DSECTS'
***********************************************************************
* OTHER DSECTS *
***********************************************************************
DIRENTRY DSECT
LINK DS A ADDR OF NEXT ENTRY
MEMBER DS CL8 MEMBER NAME
MEMTTR DS XL3 TTR OF MEMBER
USEROPT DS X N IN TTRN OF MEMBER
USERDATA DS 62X OPTIONAL USERDATA
DIRENTLG EQU *-LINK MAXIMUM LENGTH OF TABLE ENTRY
TITLE 'P D R E S T - MVS DSECTS'
***********************************************************************
* MVS DSECTS *
***********************************************************************
DCBD DSORG=PS,DEVD=DA
CVT DSECT=YES
IKJPPL
IKJUPT
IKJCPPL
IKJIOPL
IEFZB4D0
IEFZB4D2
END
Curious what you meant by HRECOVER 'not working'? If there is more than one backup version maintained but you didn't specify which to restore from it will use the latest. If your member was deleted prior to that backup you'd not retrieve what you want. You'd have to specify an earlier backup version to restore, and perhaps a NEWNAME to restore it to so you don't downlevel the whole library.
To see what backups you have:
HLIST DSN('pds.name') BCDS TER
then specify the generation that was taken on the appropriate date:
HRECOVER pds.name GEN(2)
Use TSO HELP HRECOVER to see and understand the parameters.
If you have PDSMAN installed that also has a PDS member recovery option