IBM Mainframe Forum Index
 
Log In
 
IBM Mainframe Forum Index Mainframe: Search IBM Mainframe Forum: FAQ Register
 

How to recover deleted members of a pds


IBM Mainframe Forums -> TSO/ISPF
Post new topic   Reply to topic
View previous topic :: View next topic  
Author Message
vinit_infy
Warnings : 1

New User


Joined: 07 Apr 2005
Posts: 56

PostPosted: Tue May 10, 2011 10:41 am
Reply with quote

Hi,

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.

Thanks!!
Back to top
View user's profile Send private message
enrico-sorichetti

Superior Member


Joined: 14 Mar 2007
Posts: 10872
Location: italy

PostPosted: Tue May 10, 2011 10:52 am
Reply with 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

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
Back to top
View user's profile Send private message
Bill Woodger

Moderator Emeritus


Joined: 09 Mar 2011
Posts: 7309
Location: Inside the Matrix

PostPosted: Tue May 10, 2011 3:59 pm
Reply with quote

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.

Obvious, but make sure you now have a backup.
Back to top
View user's profile Send private message
Phrzby Phil

Senior Member


Joined: 31 Oct 2006
Posts: 1042
Location: Richmond, Virginia

PostPosted: Tue May 10, 2011 5:03 pm
Reply with quote

So what's in the lost members?

E.g., if programs, and you have a compile listing, you can write a program to pull the code out.

If parms of some kind, say sort, and you have batch run prints available, you can pull them out of the SYSOUT or SYSPRINT files.
Back to top
View user's profile Send private message
PeterHolland

Global Moderator


Joined: 27 Oct 2009
Posts: 2481
Location: Netherlands, Amstelveen

PostPosted: Tue May 10, 2011 5:13 pm
Reply with quote

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.
Back to top
View user's profile Send private message
Phrzby Phil

Senior Member


Joined: 31 Oct 2006
Posts: 1042
Location: Richmond, Virginia

PostPosted: Tue May 10, 2011 5:19 pm
Reply with quote

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.
Back to top
View user's profile Send private message
Pedro

Global Moderator


Joined: 01 Sep 2006
Posts: 2546
Location: Silicon Valley

PostPosted: Wed May 11, 2011 2:13 am
Reply with quote

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:

Code:
//STEP1 EXEC PGM=ADRDSSU,REGION=7000K                   
//SYSPRINT DD SYSOUT=H                                 
//SYS117 DD DISP=SHR,DSN=PEDRO.INSTALL.EXEC             
//SYSIN DD  *                                           
  PRINT DATASET(PEDRO.INSTALL.EXEC) INDD(SYS117)    SHR
/*EOF

Though it might not be worth the effort.

You can eyeball the sysprint and possibly find your missing member (very hard if there are lots of members)
Back to top
View user's profile Send private message
Bill Woodger

Moderator Emeritus


Joined: 09 Mar 2011
Posts: 7309
Location: Inside the Matrix

PostPosted: Wed May 11, 2011 5:28 am
Reply with quote

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 icon_biggrin.gif

I hope you are lucky, lucky.
Back to top
View user's profile Send private message
enrico-sorichetti

Superior Member


Joined: 14 Mar 2007
Posts: 10872
Location: italy

PostPosted: Wed May 11, 2011 10:25 am
Reply with quote

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
Back to top
View user's profile Send private message
enrico-sorichetti

Superior Member


Joined: 14 Mar 2007
Posts: 10872
Location: italy

PostPosted: Wed May 11, 2011 10:38 am
Reply with quote

PART 2
Code:

         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

Back to top
View user's profile Send private message
enrico-sorichetti

Superior Member


Joined: 14 Mar 2007
Posts: 10872
Location: italy

PostPosted: Wed May 11, 2011 10:39 am
Reply with quote

PART 3
Code:

         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

Back to top
View user's profile Send private message
Phrzby Phil

Senior Member


Joined: 31 Oct 2006
Posts: 1042
Location: Richmond, Virginia

PostPosted: Wed May 11, 2011 5:16 pm
Reply with quote

I'll wait for the movie.
Back to top
View user's profile Send private message
gylbharat

Active Member


Joined: 31 Jul 2009
Posts: 565
Location: Bangalore

PostPosted: Wed May 11, 2011 7:04 pm
Reply with quote

Hi all,

There is an option in StarTool to recover the deleted member of the PDS.
Back to top
View user's profile Send private message
Akatsukami

Global Moderator


Joined: 03 Oct 2009
Posts: 1788
Location: Bloomington, IL

PostPosted: Wed May 11, 2011 7:20 pm
Reply with quote

gylbharat wrote:
Hi all,

There is an option in StarTool to recover the deleted member of the PDS.

Yes, and all you need do is buy StarTool out of your own pocket and donate it to every shop that doesn't already have it icon_razz.gif
Back to top
View user's profile Send private message
expat

Global Moderator


Joined: 14 Mar 2007
Posts: 8797
Location: Welsh Wales

PostPosted: Wed May 11, 2011 7:50 pm
Reply with quote

Of course, having a comprehensive backup strategy would be a far easier option.

If your site needs a storage management lesson, I can do it at a reasonable rate icon_lol.gif
Back to top
View user's profile Send private message
Pete Wilson

Active Member


Joined: 31 Dec 2009
Posts: 580
Location: London

PostPosted: Mon May 23, 2011 4:17 pm
Reply with quote

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
Back to top
View user's profile Send private message
View previous topic :: :: View next topic  
Post new topic   Reply to topic View Bookmarks
All times are GMT + 6 Hours
Forum Index -> TSO/ISPF

 


Similar Topics
Topic Forum Replies
No new posts Duplicate several members of/in one l... JCL & VSAM 7
No new posts list pds members name starting with xyz CLIST & REXX 11
No new posts REXX editmacro to compare two members... CLIST & REXX 7
No new posts Easy way to delete selected members f... IBM Tools 12
No new posts To find an array of words (sys-symbol... JCL & VSAM 9
Search our Forums:

Back to Top