//COPYPDS JOB (JOB),
//             'INSTALL COPYPDS',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//ASMFCL EXEC ASMFCL,PARM.ASM='NODECK,OBJECT,NOXREF,NORLD',
//             PARM.LKED='LIST,MAP,NCAL,RENT,REUS,REFR',
//             COND.LKED=(0,NE,ASM)
//ASM.SYSIN DD DATA,DLM=@@
         TITLE '   C O P Y P D S  '
***********************************************************************
*                                                                     *
*        'COPYPDS' TSO COMMAND                                        *
*                                                                     *
***********************************************************************
*
* WRITTEN BY BILL GODFREY, PRC INC.
*  (PRC INC. OF MCLEAN, VIRGINIA, WAS FORMERLY PLANNING RESEARCH CORP.)
* CURRENT INSTALLATION:
*  NOAA (NATIONAL OCEANIC AND ATMOSPHERIC ADMINISTRATION),
*  5200 AUTH ROAD, CAMP SPRINGS, MARYLAND 20746
* DATE WRITTEN: JUNE 14 1979.
* DATE UPDATED: APRIL 25 1991.
* ATTRIBUTES: RE-ENTRANT.
* DISCLAIMER: NO GUARANTEE; NO WARRANTY; INSTALL/USE AT YOUR OWN RISK.
* DESCRIPTION.
*         THIS TSO COMMAND COPIES A PARTITIONED DATA SET,
*         USING THE IEBCOPY UTILITY PROGRAM.
*
*         IF IT INVOKES IEBCOPY DIRECTLY, ON A NON-TSO/E SYSTEM,
*         IT MUST BE LINK-EDITED AS AN AUTHORIZED PROGRAM AND
*         THE NAME OF THE COMMAND MUST BE ADDED TO THE TABLE
*         OF AUTHORIZED COMMANDS IN IKJEFT02 CSECT IKJEFTE2.
*
*         HOWEVER, BY DEFAULT ON NON-TSO/E SYSTEMS IT INVOKES 'SPFCOPY'
*         WHICH IS A PROGRAM THAT INVOKES IEBCOPY AFTER TAKING CARE
*         OF THE AUTHORIZATION ITSELF.
*
*         ON TSO/E SYSTEMS IT INVOKES 'IEBCOPY' VIA THE TSO
*         SERVICE ROUTINE, SO 'IEBCOPY' MUST BE IN THE TABLE
*         IN MEMBER IKJEFT02 CSECT IKJEFTAP.
*
*  THIS COMMAND WAS WRITTEN TO PROVIDE THE FOLLOWING CAPABILITIES
*  TO TSO USERS -
*
*     .  COPY ONE PDS TO ANOTHER, WITH AN OPTION TO KEEP OR REPLACE
*        IDENTICALLY NAMED MEMBERS.
*     .  COPY SELECTED MEMBERS AND ALIASES FROM ONE PDS TO ANOTHER,
*     .  COPY LOAD MODULES TO A LIBRARY HAVING A DIFFERENT BLOCKSIZE
*        WITHOUT ATTEMPTING TO REBLOCK THEM (LIKE A CERTAIN OTHER
*        COMMAND UNSUCCESSFULLY DOES).
*     .  IN SHORT, DO ANYTHING IEBCOPY CAN DO EXCEPT A) COMPRESS,
*        AND B) COPY SOME MEMBERS WITH REPLACE AND OTHERS WITHOUT
*        REPLACE. (COMPRESS IS DONE WITH ANOTHER COMMAND).
*     .  REQUIRE THAT THE OUTPUT PDS ALREADY EXIST, SO THAT IF
*        THE USER MISSPELLS THE OUTPUT DSNAME A MESSAGE WILL BE
*        ISSUED INSTEAD OF A NEW DATA SET BEING CREATED.
*
***********************************************************************
         EJECT
***********************************************************************
*
*         LOG OF CHANGES.
*            09OCT79 - 3330 ADDED. DELETE IKJPUTL ADDED. GBLB ADDED.
*            09OCT79 - STACK DELETE. TIOTSCAN, VOL COMPARISON.
*            13MAY80 - ADD ERRPD2 ROUTINE FOR DSNAM2. FIX CLEAR.
*            23FEB81 - 3330V ADDED. CHECK FOR EXISTING MEMBER IN
*                      OUTPUT DATA SET WHEN 'SELECT' IS SPECIFIED
*                      BUT 'REPLACE' IS NOT.  IF OUTPUT PDS LACKS
*                      DCB ATTRIBUTES (WAS JUST CREATED), OUR OPEN
*                      MAY FORCE RECFM U, SO SPECIFY REPLACE.
*                      ADDED OBTAIN-DSCB TO CHECK FOR NO-ATTRIBUTES.
*                      IUNIT, OUNIT, LOAD, UNLOAD KEYWORDS.
*            07MAY81 - LIST KEYWORD ADDED TO SUPPRESS LIST=NO.
*                      SECOND BASE REGISTER ADDED.
*                      A MEMBER NAME MAY NOW BE SPECIFIED WITH
*                      THE INPUT DSNAME. IT WILL BE TREATED
*                      EXACTLY AS IF IT HAD BEEN SPECIFIED IN THE
*                      'SELECT' OPERAND. IF 'SELECT' MEMBERS ARE
*                      ALSO SPECIFIED, THE MEMBER IN THE DSNAME IS
*                      INCLUDED IN FRONT OF THE SPECIFIED MEMBERS.
*                      IF (AND ONLY IF) THE INPUT DSNAME HAS A
*                      MEMBER NAME, THE OUTPUT DSNAME MAY HAVE ONE
*                      ALSO, BUT IT DOESNT HAVE TO UNLESS YOU WANT
*                      THE MEMBER NAME TO BE DIFFERENT.
*            28DEC89 - UNDER TSO/E INVOKE IEBCOPY VIA TSO SERVICE RTN.
*            12JAN90 - ADD ISPF ENQ/RESERVE. ADD 3380 TO DEFAULT UNIT.
*            16JAN90 - BRING UCB SEARCH ROUTINE UP TO XA LEVEL.
*                      ADD COMMENTS ABOUT ZAP FOR MSG IEB173I.
*            26APR90 - CHANGE 'BNE' IN FRONT OF DEQ'S TO 'BE'.
*                      ADD RETUCB.
*                      ALLOCATE SYSPRINT TO TERMINAL USING SVC 99
*                      TO AVOID MSG IEB173I.
*            25APR91 - CHECK FOR 3390.
*
*            THERE ARE 3 WAYS TO COPY ONE MEMBER:
*               COPYPDS X.DATA Y.DATA SELECT(MEM)
*               COPYPDS X.DATA(MEM) Y.DATA
*               COPYPDS X.DATA(MEM) Y.DATA(MEM)
*
*            ALLOCATION UNITNAME 'SYSDA' IS HARD-CODED IN THIS
*            COMMAND FOR SYSUT3 AND SYSUT4 WORKSPACE.  THIS MAY
*            BE CHANGED TO 'SYSVIO' OR SOME VIO UNITNAME
*            IF THE COMMAND IS TO RUN AT ANOTHER INSTALLATION.
*
***********************************************************************
         EJECT
***********************************************************************
*
*            THE SYNTAX IS:
*
*               COPYPDS 'INDSNAME' 'OUTDSNAME' SELECT(MEMBER,...)
*
*            A MEMBER CAN BE GIVEN A NEW NAME WHEN IT IS COPIED
*            IF SELECT(MEMBER1:NEWNAME1 MEMBER2:NEWNAME2) IS USED.
*            A COLON SEPARATES THE OLD NAME AND NEW NAME.
*
*            OPTIONAL KEYWORDS ARE:
*               REPLACE  - REPLACE IDENTICALLY NAMED MEMBERS.
*               SHR      - ALLOCATE THE OUTPUT DATA SET SHARED.
*               LIST     - DONT TELL IEBCOPY LIST=NO.
*               LOAD     - INPUT DATA SET IS SEQUENTIAL, CREATED
*                          BY A PREVIOUS IEBCOPY UNLOAD.
*               UNLOAD   - OUTPUT DATA SET IS SEQUENTIAL, TO BE
*                          WRITTEN IN IEBCOPY UNLOADED FORMAT.
*               IEBCOPY  - USE IEBCOPY INSTEAD OF SPFCOPY.
*               IVOL(VOLUME) - VOLUME CONTAINING THE IN DATA SET.
*                          NOT NEEDED IF CATALOGED.
*               OVOL(VOLUME) - VOLUME CONTAINING THE OUT DATA SET.
*                          NOT NEEDED IF CATALOGED.
*               IUNIT(UNIT) - UNIT NAME FOR ALLOCATING THE INPUT
*                          DATA SET. NOT NEEDED IF CATALOGED.
*               OUNIT(UNIT) - UNIT NAME FOR ALLOCATING THE OUTPUT
*                          DATA SET. NOT NEEDED IF CATALOGED.
*               SYSOUT   - MESSAGES TO A SYSOUT DATA SET.
*               PRINT    - MESSAGES TO TERMINAL (DEFAULT).
*               NOPRINT  - MESSAGES TO DUMMY FILE.
*               OUTFILE(FILENAME) - MESSAGES TO SPECIFIED DDNAME.
*            MOST OF THE ABOVE ARE NOT DOCUMENTED IN 'HELP'.
*            THEY ARE NOT NEEDED 99 PERCENT OF THE TIME.
*
*            LOAD AND UNLOAD WERE WRITTEN FOR A SPECIAL APPLICATION
*            WHICH HAD ACCESS TO TAPES, SO THEY WILL PROBABLY HAVE
*            NO PURPOSE AT MOST OTHER INSTALLATIONS.
*
*            WHEN THE IVOL OR OVOL KEYWORDS ARE USED TO INDICATE
*            TWO IDENTICALLY NAMED DATASETS ON DIFFERENT VOLUMES
*            ARE BEING USED, UNEXPECTED RESULTS CAN OCCUR UNLESS
*            BOTH IVOL AND OVOL ARE SPECIFIED.  FOR EXAMPLE, IF
*            IVOL IS SPECIFIED AND OVOL IS NOT, THE ALLOCATION
*            OF 'OUTDSNAME' WITH NO VOLUME SPECIFIED MAY PICK UP
*            THE ALREADY ALLOCATED 'INDSNAME' INSTEAD OF THE
*            'OUTDSNAME' IN THE CATALOG.
*
***********************************************************************
         EJECT
***********************************************************************
*
*            YOU MAY WANT TO MAKE A MODIFIED COPY OF IEBCOPY
*            THAT ISSUES FEWER MESSAGES. HERE ARE SOME ZAPS THAT
*            HAVE WORKED IN THE PAST BUT HAVE NOT BEEN KEPT
*            UP TO DATE WITH MORE RECENT PTFS TO IEBCOPY.
*
*            ZEBCOPY IS A COPY OF THE IEBCOPY UTILITY THAT HAS
*            BEEN ZAPPED TO SUPPRESS THE FOLLOWING MESSAGES:
*               IEB161I COMPRESS TO BE DONE
*               IEB152I MEMBER COMPRESSED - WAS ALREADY IN PLACE
*               IEB167I FOLLOWING MEMBER(S) COPIED
*               IEB154I MEMBER HAS BEEN SUCCESSFULLY COPIED
*               IEB153I ALL MEMBER COMPRESSED - ALL WERE ORIGINALLY
*               IEB144I THERE ARE NNNNN UNUSED TRACKS
*               IEB149I THERE ARE NNNNN UNUSED DIRECTORY BLOCKS
*               IEB147I END OF JOB - NN WAS HIGHEST SEVERITY CODE
*
*               NAME ZEBCOPY IEBVMS
*               VER 0082 1233,4780
*               REP 0084      4700        SUPPRESS HEADING
*
*               NAME ZEBCOPY IEBMCM
*               VER 01BC 9230,4B29
*               VER 01D0 05EF
*               REP 01D0 0700             SUPPRESS IEB152I
*               VER 01DA 9231,4B29
*               VER 01E6 05EF
*               REP 01E6 0700             SUPPRESS IEB153I
*
*               NAME ZEBCOPY IEBVTM
*               VER 0402 9104,4B1D,4710
*               REP 0406           47F0   SUPPRESS IEB167I
*               VER 0450 9104,4B1D,4710
*               REP 0454           47F0   SUPPRESS IEB154I
*
***********************************************************************
         EJECT
***********************************************************************
*
*               NAME ZEBCOPY IEBVTM
*               VER 056C 9228,4B29
*               VER 0578 05EF
*               REP 0578 0700             SUPPRESS IEB144I
*               VER 05BC 922D,4B29
*               VER 05C8 05EF
*               REP 05C8 0700             SUPPRESS IEB149I
*               VER 068A 922B,4B29
*               VER 0696 05EF
*               REP 0696 0700             SUPPRESS IEB147I
*
*               NAME ZEBCOPY IEBDV1
*               VER 0B14 9239,4B29
*               VER 0B24 47F0,CB56
*               REP 0B24 47F0,8000        SUPPRESS IEB161I
*
*
*            WHEN ALLOCATING SYSPRINT TO THE TERMINAL (WHICH IS
*            THE DEFAULT) THE SYSTEM WILL USE AN EXISTING ALLOCATION
*            IF IT FINDS ONE. THIS SOMETIMES CAUSES IEBCOPY TO
*            TERMINATE WITH THE FOLLOWING MESSAGES:
*               IEB120I DDNAMEXX VALIDATION ERROR
*               IEB125I INVALID BLOCKSIZE
*            THIS IS BECAUSE THE PREVIOUS PROGRAM TO WRITE IN THE
*            EXISTING ALLOCATION HAD A BLOCKSIZE THAT WAS NOT A
*            MULTIPLE OF 121.  TO FORCE IEBCOPY TO IGNORE THAT
*            CONDITION AND USE ITS OWN BLOCKSIZE, ZAP IT AS FOLLOWS:
*             *LEVEL UZ26557             *LEVEL UZ90091
*             NAME ZEBCOPY IEBDV1   OR   NAME ZEBCOPY IEBDV1
*             VER 08C4 9602,4B20         VER 08D4 9602,4B20
*             REP 08C4 9600,4B20         REP 08D4 9600,4B20
*
*            TO SUPPRESS WTO MESSAGE
*            IEB173I SYSPRINT - INVALID BLOCKSIZE
*             *LEVEL UZ72727 JDQ1110
*             NAME ZEBCOPY IEBDV1
*             VER 097C 9602,4B34
*             REP 097C 9600,4B34
*
*            AFTER ALL THE ABOVE ZAPS ARE APPLIED, THE ONLY TIME
*            A MESSAGE WILL APPEAR WILL BE WHEN AN ERROR OCCURS.
*
***********************************************************************
         EJECT
         GBLB  &MVS
&MVS     SETB  1                   1 - MVS    0 - SVS,MVT
         SPACE
COPYPDS  START
         USING *,R10,R11
         B     @PROLOG-*(,15)
         DC    AL1(11),CL11'COPYPDS '
         DC    CL16' &SYSDATE &SYSTIME '
@SIZE    DC    0F'0',AL1(1),AL3(@DATAL) SUBPOOL AND LENGTH
@PROLOG  STM   14,12,12(R13)
         LR    R10,R15             FIRST BASE REGISTER
         LA    R15,1
         LA    R11,4095(R15,R10)   SECOND BASE REGISTER
         LR    R2,R1               PARM POINTER
         USING CPPL,R2
         L     R0,@SIZE
         GETMAIN R,LV=(0)
         LR    R9,R1               INITIALIZE WORKAREA POINTER
         USING @DATA,R9
         SPACE 1
         LR    R15,R1              AREA TO BE CLEARED
         L     R1,@SIZE            LENGTH TO BE CLEARED
         LA    R0,0(,R1)           CLEAR HIGH ORDER BYTE
         SRDL  R0,8                DIVIDE BY 256
         SRL   R1,24               ISOLATE REMAINDER
         LTR   R0,R0               IS QUOTIENT ZERO
         BZ    CLEARR              YES, GO CLEAR REMAINDER
CLEARQ   XC    0(256,R15),0(R15)   CLEAR 256 BYTES
         LA    R15,256(,R15)
         BCT   R0,CLEARQ           DECREMENT QUOTIENT AND BRANCH
CLEARR   LTR   R1,R1               IS REMAINDER ZERO
         BZ    CLEARX              YES, BRANCH TO FINISH
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BYPASS EXECUTED INSTR
         XC    0(0,R15),0(R15)     (EXECUTED)
         EX    R1,*-6              DO THE ABOVE XC
CLEARX   EQU   *
         SPACE 1
         ST    R13,4(,R9)          CHAIN FORWARD
         ST    R9,8(,R13)          CHAIN BACK
         LR    R13,R9              UPDATE SAVEAREA POINTER
         SPACE 1
************************************************************
*                                                          *
*        SET UP IOPL FOR PUTLINE                           *
*                                                          *
************************************************************
         SPACE
         LA    R15,MYIOPL
         USING IOPL,R15
         MVC   IOPLUPT(4),CPPLUPT
         MVC   IOPLECT(4),CPPLECT
         LA    R0,MYECB
         ST    R0,IOPLECB
         XC    MYECB,MYECB
         LA    R0,MYPTPB
         ST    R0,IOPLIOPB
         DROP  R15                 IOPL
         SPACE
         AIF   (NOT &MVS).SKIP1
         L     R15,16              LOAD CVT POINTER
         TM    444(R15),X'80'      IS PUTLINE LOADED? (VS2)
         BNO   PUTLOAD             NO - BRANCH TO LOAD
         L     R15,444(,R15)       YES - USE CVTPUTL
         B     PUTLODED            BRANCH AROUND LOAD
.SKIP1   ANOP
PUTLOAD  LA    R0,=CL8'IKJPUTL '
         LOAD  EPLOC=(0)
         LR    R15,R0              GET ENTRY ADDRESS
         LA    R15,0(,R15)         CLEAR HI BYTE FOR DELETE ROUTINE
PUTLODED ST    R15,MYPUTLEP        SAVE PUTLINE ENTRY ADDRESS
         SPACE
************************************************************
*                                                          *
*        SET UP DAPL FOR IKJDAIR                           *
*                                                          *
************************************************************
         SPACE
         LA    R15,MYDAPL
         USING DAPL,R15
         MVC   DAPLUPT(12),MYIOPL  UPT,ECT,ECB
         MVC   DAPLPSCB,CPPLPSCB
         LA    R0,MYDAPB
         ST    R0,DAPLDAPB
         DROP  R15                 DAPL
         SPACE
************************************************************
*                                                          *
*        SET UP PPL FOR PARSE                              *
*                                                          *
************************************************************
         SPACE
         LA    R15,MYPPL
         USING PPL,R15
         MVC   PPLUPT(4),CPPLUPT
         MVC   PPLECT(4),CPPLECT
         LA    R0,MYECB
         ST    R0,PPLECB
         XC    MYECB,MYECB
         L     R0,=A(COMPRPCL)
         ST    R0,PPLPCL
         LA    R0,MYANS
         ST    R0,PPLANS
         MVC   PPLCBUF(4),CPPLCBUF
         ST    R9,PPLUWA
         DROP  R15                 PPL
         SPACE 1
************************************************************
*                                                          *
*        CALL THE PARSE SERVICE ROUTINE                    *
*                                                          *
************************************************************
         SPACE 1
         LR    R1,R15              POINT TO PPL
         AIF   (NOT &MVS).SKIP2
         L     R15,16              CVTPTR
         TM    X'020C'(R15),X'80'  IF HI ORDER BIT NOT ON
         BNO   PARSELNK               THEN DO LINK, NOT CALL
         L     R15,X'020C'(,R15)   CVTPARS
         BALR  R14,R15             CALL IKJPARS
         B     PARSEEXT            SKIP AROUND LINK
PARSELNK EQU   *
.SKIP2   ANOP
         LINK  EP=IKJPARS,SF=(E,LINKAREA)
PARSEEXT EQU   *
         SPACE 1
         LTR   R15,R15             PARSE SUCCESSFUL?
         BZ    PARSEOK             YES, BRANCH
         LA    R1,MSG01
         LA    R0,L'MSG01
         BAL   R14,PUTMSG
         B     EXIT12
PARSEOK  EQU   *
         L     R3,MYANS
         USING IKJPARMD,R3
         MVI   DSNAME+2,C' '
         MVC   DSNAME+3(43),DSNAME+2
         MVC   DSNAM2+2(44),DSNAME+2
         SPACE
************************************************************
*                                                          *
*         PROCESS INPUT DSNAME MEMBER                      *
*                                                          *
************************************************************
         SPACE
         LA    R4,DSN
         XC    MEMDSPDE(20),MEMDSPDE
         TM    14(R4),X'80'        MEMBER NAME SPECIFIED?
         BZ    MEMDS1X             NO, BRANCH
         MVC   MEMDSPDE(8),8(R4)   CREATE FAKE 'SELECT' PDE
         MVI   MEMDSPDE+16,X'FF'   LAST PDE
         CLI   MEMKW+1,0           SELECT/EXCLUDE ALSO SPECIFIED
         BE    MEMDS1X             NO, FAKE PDE IS COMPLETE
         CLI   MEMKW+1,1           IS IT SELECT
         BNE   ERRMIX              NO, DSN(MEM) WITH EXCLUDE, ERROR
         LA    R1,MEM              POINT TO SELECT PDE
         ST    R1,MEMDSPDE+16      CHAIN IT TO FAKE PDE
MEMDS1X  EQU   *
         SPACE
************************************************************
*                                                          *
*         PROCESS INPUT DSNAME                             *
*                                                          *
************************************************************
         SPACE
         TM    6(R4),X'80'         DSNAME PRESENT
         BZ    ERRNODSN            NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF DSNAME
         LTR   R1,R1               IS LENGTH ZERO
         BZ    EXIT12              YES, BRANCH
         STH   R1,DSNAME           DSN LENGTH IN DAIR BUFFER
         L     R15,0(,R4)          GET ADDRESS OF DSNAME
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DSNAME+2(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE DSNAME TO DAIR BUFFER
         SPACE
         LA    R5,MYDAPB           POINT TO DAIR PARAMETER BLOCK
         USING DAPB08,R5
         MVC   DA08CD(84),MODEL08  MOVE 08 MODEL DAPB
         LA    R0,DSNAME
         ST    R0,DA08PDSN
         SPACE
         TM    22(R4),X'80'        DSNAME/PASSWORD SPECIFIED?
         BZ    NOPASS              NO, BRANCH
         LH    R1,20(,R4)          YES, GET LENGTH OF PASSWORD
         LTR   R1,R1               LENGTH ZERO
         BZ    NOPASS              YES, BRANCH
         L     R15,16(,R4)         GET ADDRESS OF PASSWORD
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INST
         MVC   DA08PSWD(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE PASSWORD TO DAPB
NOPASS   EQU   *
         SPACE
         OI    DA08DSP1,X'08'      DISP=SHR
         AIF   (&MVS).SKIP3        DAIR TO PREFIX DSNAME
         TM    6(R4),X'40'         IS DSNAME IN QUOTES
         BO    *+8                 YES, BRANCH
         OI    DA08CTL,X'20'       NO, TELL DAIR TO PREFIX DSNAME
.SKIP3   ANOP
         SPACE
************************************************************
*                                                          *
*        INPUT UNIT AND VOLUME                             *
*                                                          *
************************************************************
         SPACE
         LA    R4,IVOL
         TM    6(R4),X'80'         VOLUME SPECIFIED
         BZ    NOVOL               NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF VOLUME
         LTR   R1,R1               IS LENGTH ZERO
         BZ    NOVOL               YES, BRANCH
         L     R15,0(,R4)          GET ADDRESS OF VOLUME
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DA08SER(0),0(R15)   (EXECUTED)
         EX    R1,*-6              MOVE VOLUME TO DAIR PARAM
         SPACE
         LA    R4,IUNI
         TM    6(R4),X'80'         UNIT SPECIFIED
         BZ    IUNIT2              NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF UNIT
         LTR   R1,R1               IS LENGTH ZERO
         BZ    IUNIT2              YES, BRANCH
         L     R15,0(,R4)          GET ADDRESS OF UNIT
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DA08UNIT(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE VOLUME TO DAIR PARAM
         B     IUNITX
         SPACE
IUNIT2   LA    R1,DA08SER          POINT TO VOLSER FOR UCB SEARCH
         BAL   R14,CUU             FIND UCB FOR VOLUME
         LTR   R15,R15             DASD UCB FOUND?
         BZ    IUNITX              NO, LEAVE UNIT TO SESSION DEFAULT
         CLI   19(R15),X'0F'       3390?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3390'
         CLI   19(R15),X'0E'       3380?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3380'
         CLI   19(R15),X'0C'       3375?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3375'
         CLI   19(R15),X'0B'       3350?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3350'
         CLI   19(R15),X'0D'       3330-1?
         BNE   *+10                NO
         MVC   DA08UNIT(6),=C'3330-1'
         CLI   19(R15),X'09'       3330?
         BNE   IUNITX              NO
         MVC   DA08UNIT(4),=C'3330-1'  NOTE. ONLY MOVE 4 BYTES.
         TM    17(R15),X'08'       3330V (MSS VIRTUAL VOLUME)
         BZ    *+8
         MVI   DA08UNIT+4,C'V'     MAKE IT 3330V
IUNITX   EQU   *
NOVOL    EQU   *
         SPACE
************************************************************
*                                                          *
*        ALLOCATE THE INPUT DATA SET                       *
*                                                          *
************************************************************
         SPACE
         BAL   R14,CALLDAIR
         SPACE
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDUT1(8),DA08DDN    SAVE DDNAME
         SPACE
************************************************************
*                                                          *
*        VERIFY THAT DATA SET IS PARTITIONED               *
*                                                          *
************************************************************
         SPACE
         MVC   DSORG1,DA08DSO
         CLI   LOADKW+1,1          IS 'LOAD' SPECIFIED
         BE    *+12                YES, DONT CHECK DSORG
         TM    DA08DSO,X'02'
         BZ    ERRPDS
         SPACE
************************************************************
*                                                          *
*         PROCESS SECOND OPERAND DSNAME2 MEMBERNAME        *
*                                                          *
************************************************************
         SPACE
         LA    R4,DS2
         TM    14(R4),X'80'        MEMBER NAME SPECIFIED?
         BZ    MEMDS2X             NO, BRANCH
         TM    MEMDSPDE+6,X'80'    WAS MEMBER SPECIFIED IN INPUT DSN
         BZ    ERRMIX2             NO, OUTPUT CANNOT BE ONE MEMBER
         MVC   MEMDSPDE+8(8),8(R4) CREATE FAKE 'SELECT' PDE NEWNAME
         LH    R1,MEMDSPDE+4       GET LENGTH OF INPUT MEMBER NAME
         CH    R1,MEMDSPDE+12      ARE LENGTHS EQUAL
         BNE   MEMDS2X             NO, BRANCH
         L     R14,MEMDSPDE        POINT TO INPUT MEMBER NAME
         L     R15,MEMDSPDE+8      POINT TO OUTPUT MEMBER NAME
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10
         CLC   0(0,R14),0(R15)     EXECUTED
         EX    R1,*-6              COMPARE MEMBER NAMES
         BNE   MEMDS2X             OK IF DIFFERENT
         XC    MEMDSPDE+8(8),MEMDSPDE+8 ZERO SECOND NAME IF SAME
MEMDS2X  EQU   *
         SPACE
************************************************************
*                                                          *
*         PROCESS SECOND OPERAND DSNAME2                   *
*                                                          *
************************************************************
         SPACE
         TM    6(R4),X'80'         DSNAME PRESENT
         BZ    ERRNODSN            NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF DSNAME
         LTR   R1,R1               IS LENGTH ZERO
         BZ    EXIT12              YES, BRANCH
         STH   R1,DSNAM2           DSN LENGTH IN DAIR BUFFER
         L     R15,0(,R4)          GET ADDRESS OF DSNAME
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DSNAM2+2(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE DSNAME TO DAIR BUFFER
         SPACE
         LA    R5,MYDAPB           POINT TO DAIR PARAMETER BLOCK
         USING DAPB08,R5
         MVC   DA08CD(84),MODEL08  MOVE 08 MODEL DAPB
         LA    R0,DSNAM2
         ST    R0,DA08PDSN
         SPACE
         TM    22(R4),X'80'        DSNAME/PASSWORD SPECIFIED?
         BZ    NOPAS2              NO, BRANCH
         LH    R1,20(,R4)          YES, GET LENGTH OF PASSWORD
         LTR   R1,R1               LENGTH ZERO
         BZ    NOPAS2              YES, BRANCH
         L     R15,16(,R4)         GET ADDRESS OF PASSWORD
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INST
         MVC   DA08PSWD(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE PASSWORD TO DAPB
NOPAS2   EQU   *
         SPACE
         CLI   OSHRKW+1,2          SHR OR OSHR
         BNL   DISP2S              YES, BRANCH
         OI    DA08DSP1,X'01'      DISP=OLD
         B     DISP2X
DISP2S   OI    DA08DSP1,X'08'      DISP=SHR
DISP2X   EQU   *
         AIF   (&MVS).SKIP4        DAIR TO PREFIX DSNAME
         TM    6(R4),X'40'         IS DSNAME IN QUOTES
         BO    *+8                 YES, BRANCH
         OI    DA08CTL,X'20'       NO, TELL DAIR TO PREFIX DSNAME
.SKIP4   ANOP
         SPACE
************************************************************
*                                                          *
*        OUTPUT UNIT AND VOLUME                            *
*                                                          *
************************************************************
         SPACE
         LA    R4,OVOL
         TM    6(R4),X'80'         VOLUME SPECIFIED
         BZ    NOVOL2              NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF VOLUME
         LTR   R1,R1               IS LENGTH ZERO
         BZ    NOVOL2              YES, BRANCH
         L     R15,0(,R4)          GET ADDRESS OF VOLUME
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DA08SER(0),0(R15)   (EXECUTED)
         EX    R1,*-6              MOVE VOLUME TO DAIR PARAM
         LA    R4,OUNI
         TM    6(R4),X'80'         UNIT SPECIFIED
         BZ    OUNIT2              NO, BRANCH
         LH    R1,4(,R4)           GET LENGTH OF UNIT
         LTR   R1,R1               IS LENGTH ZERO
         BZ    OUNIT2              YES, BRANCH
         L     R15,0(,R4)          GET ADDRESS OF UNIT
         BCTR  R1,0                LENGTH MINUS 1 FOR EX
         B     *+10                BRANCH AROUND EXECUTED INS
         MVC   DA08UNIT(0),0(R15)  (EXECUTED)
         EX    R1,*-6              MOVE VOLUME TO DAIR PARAM
         B     OUNITX
         SPACE
OUNIT2   LA    R1,DA08SER          POINT TO VOLSER FOR UCB SEARCH
         BAL   R14,CUU             FIND UCB FOR VOLUME
         LTR   R15,R15             DASD UCB FOUND?
         BZ    OUNITX              NO, LEAVE UNIT TO SESSION DEFAULT
         CLI   19(R15),X'0E'       3380?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3380'
         CLI   19(R15),X'0B'       3350?
         BNE   *+10                NO
         MVC   DA08UNIT(4),=C'3350'
         CLI   19(R15),X'0D'       3330-1?
         BNE   *+10                NO
         MVC   DA08UNIT(6),=C'3330-1'
         CLI   19(R15),X'09'       3330?
         BNE   OUNITX              NO
         MVC   DA08UNIT(4),=C'3330-1'  NOTE. ONLY MOVE 4 BYTES.
         TM    17(R15),X'08'       3330V (MSS VIRTUAL VOLUME)
         BZ    *+8
         MVI   DA08UNIT+4,C'V'     MAKE IT 3330V
OUNITX   EQU   *
NOVOL2   EQU   *
         SPACE
************************************************************
*                                                          *
*        ALLOCATE THE OUTPUT PDS                           *
*                                                          *
************************************************************
         SPACE
         BAL   R14,CALLDAIR
         SPACE
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDUT2(8),DA08DDN    SAVE DDNAME
         SPACE
************************************************************
*                                                          *
*        VERIFY THAT DATA SET IS PARTITIONED               *
*                                                          *
************************************************************
         SPACE
         MVC   DSORG2,DA08DSO
         CLI   UNLOKW+1,1          IS 'UNLOAD' SPECIFIED
         BE    *+12                YES, DONT CHECK DSORG
         TM    DA08DSO,X'02'
         BZ    ERRPD2
         SPACE
************************************************************
*                                                          *
*        CHECK FOR IDENTICAL DSNAMES AND VOLUMES           *
*                                                          *
************************************************************
         SPACE
         CLC   DSNAME+2(44),DSNAM2+2
         BNE   OKDIFF
         LA    R4,DDUT1            POINT TO INPUT DDNAME
         BAL   R14,TIOTSCAN
         MVC   DOUBLE(6),28(R1)    HOLD VOL FROM UCB
         LA    R4,DDUT2            POINT TO OUTPUT DDNAME
         BAL   R14,TIOTSCAN
         CLC   DOUBLE(6),28(R1)    IS IT SAME VOLUME
         BNE   OKDIFF              NO, BRANCH
         LA    R1,MSG03
         LA    R0,L'MSG03
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
TIOTSCAN L     R15,16              CVTPTR
         L     R15,0(,R15)         TCB WORDS
         L     R15,4(,R15)         CURRENT TCB
         L     R15,12(,R15)        TCBTIOT
         LA    R15,24(,R15)        TIOENTRY
         USING TIOENTRY,R15
TIOTLOOP CLI   TIOENTRY,X'00'      END OF TIOT?
         BER   R14                 YES - RETURN
         CLC   TIOEDDNM,0(R4)      DOES DDNAME MATCH?
         BE    TIOTEXIT            YES - RETURN
         SR    R1,R1
         IC    R1,TIOELNGH         GET LENGTH OF ENTRY
         LA    R15,0(R1,R15)       POINT TO NEXT ENTRY
         B     TIOTLOOP
TIOTEXIT L     R1,TIOEFSRT-1       GET UCB ADDRESS
         BR    R14
         SPACE
OKDIFF   EQU   *
         SPACE
************************************************************
*                                                          *
*         IF OUTPUT IS NEW, WE DONT WANT TO OPEN IT        *
*                                                          *
************************************************************
         SPACE
         CLI   REPKW+1,2           WAS REPLACE SPECIFIED
         BE    OBTX                YES, BYPASS OBTAIN
         CLI   UNLOKW+1,1          WAS UNLOAD SPECIFIED
         BE    OBTX                YES, BYPASS OBTAIN
         LA    R4,DDUT2            POINT TO OUTPUT DDNAME
         BAL   R14,TIOTSCAN
         TM    18(R1),X'20'        DIRECT ACCESS DEVICE?
         BZ    OBTX                NO, BYPASS OBTAIN
         TM    0(R1),X'80'         VIO
         BO    OBTX                YES, BYPASS OBTAIN
         MVC   OBTVOL,28(R1)       UCBVOLI
OBTDSCB  LA    R1,OBTAINW
         MVC   0(OBTAINL,R1),OBTAIN
         LA    R0,DSNAM2+2         DSN FOR OBTAIN
         ST    R0,4(,R1)
         LA    R0,OBTVOL           VOLUME FOR OBTAIN
         ST    R0,8(,R1)
         LA    R0,DSCB             ANSWER AREA FOR OBTAIN
         ST    R0,12(,R1)
         OBTAIN (1)
         LTR   R15,R15             WAS OBTAIN SUCCESSFUL
         BZ    OKDSCB              YES, BRANCH
         SPACE
*               OBTAIN HAS FAILED. HOW CAN THAT HAPPEN WHEN
*               DYNAMIC ALLOCATION WAS SUCCESSFUL? ONE WAY IT
*               CAN HAPPEN IS IF THE DSNAME IS AN ALIAS ENTRY
*               IN A VSAM CATALOG.  IF IT IS, A 'LOCATE' WILL
*               PUT THE TRUE NAME IN THE DSNAME FIELD, SO NOW
*               WE ISSUE A LOCATE, AND TRY THE OBTAIN AGAIN.
         SPACE
*        TM    STATUS,STATL        HAS LOCATE BEEN TRIED ALREADY?
*        BNZ   ERROBT              YES, GO PRINT OBTAIN ERROR MSG
*        OI    STATUS,STATL        TRIP THE SWITCH
*        LA    R1,LOCATEW
*        MVC   0(LOCATEL,R1),LOCATE
*        LA    R0,DSNAM2+2         DSNAME FOR LOCATE
*        ST    R0,4(,R1)
*        LA    R0,LOCBUF           ANSWER AREA FOR LOCATE
*        ST    R0,12(,R1)
*        LOCATE (1)
*        LTR   15,15               WAS LOCATE SUCCESSFUL?
*        BZ    OBTDSCB             YES, GO OBTAIN AGAIN
         SPACE
ERROBT   LA    R1,MSG05            UNABLE TO OBTAIN DSCB
         LA    R0,L'MSG05
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
OKDSCB   EQU   *
*        NI    STATUS,255-STATL    TURN OFF LOCATE SWITCH
         TM    DSCB-44+X'52',X'02' DSORG = PO
         BZ    FORCEREP            NO, BRANCH
         TM    DSCB-44+X'54',X'C0' RECFM = U, F, OR V
         BZ    FORCEREP            NO, MUST BE NEW
         CLC   DSCB-44+X'65'(2),=H'0' IS BLKSIZE ZERO
         BNE   *+8                 NO, BRANCH
FORCEREP MVI   REPKW+1,2           FORCE REP ON
*                                  SO VERIFY WONT OPEN THE OUTPUT
*                                  PDS AND THEREBY GIVE IT A
*                                  BAD RECFM AND BLKSIZE
OBTX     EQU   *
         SPACE
************************************************************
*                                                          *
*        ALLOCATE THE SYSIN FILE (DUMMY)                   *
*                                                          *
************************************************************
         SPACE
         MVC   DA08CD(84),MODEL08
         MVC   DA08UNIT,@UNITVIO
         MVI   DA08PQTY+3,1        1 TRACK
         MVI   DA08DSP1,DA08NEW
         OI    DA08CTL,DA08TRKS
         BAL   R14,CALLDAIR
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDIN,DA08DDN
         SPACE
************************************************************
*                                                          *
*        WRITE SYSIN CONTROL STATEMENTS                    *
*                                                          *
************************************************************
         SPACE
         LA    R6,CTLDCBW
         MVC   0(CTLDCBL,R6),CTLDCB
         MVC   DDNAM(8,R6),DDIN
         LA    R1,OPEN
         MVI   0(R1),X'80'
         OPEN  ((R6),OUTPUT),MF=(E,(1))
         TM    OFLGS(R6),X'10'
         BNO   EXIT12
         MVI   CARD,C' '
         MVC   CARD+1(79),CARD
         MVC   CARD+1(7),=C'COPY I='
         LA    R15,CARD+8
         CLI   REPKW+1,2           REPLACE
         BE    CTLDD2              YES, BRANCH
         MVC   0(8,R15),DDUT1
CTLDD1   CLI   0(R15),C' '
         BE    CTLDD5
         LA    R15,1(,R15)
         B     CTLDD1
CTLDD2   MVC   0(2,R15),=C'(('
         MVC   2(8,R15),DDUT1
         LA    R15,3(,R15)
CTLDD3   CLI   0(R15),C' '
         BE    CTLDD4
         LA    R15,1(,R15)
         B     CTLDD3
CTLDD4   MVC   0(4,R15),=C',R))'
         LA    R15,4(,R15)
CTLDD5   MVC   0(3,R15),=C',O='
         MVC   3(8,R15),DDUT2
CTLDD6   CLI   3(R15),C' '
         BE    CTLDD7
         LA    R15,1(,R15)
         B     CTLDD6
CTLDD7   CLI   LISTKW+1,2          LIST REQUESTED
         BNL   *+10                YES, SKIP MVC
         MVC   3(8,R15),=C',LIST=NO'
         PUT   (R6),CARD
         TM    MEMDSPDE+6,X'80'    WAS MEMBER SPECIFIED WITH INPUT DSN
         BZ    *+8                 NO
         MVI   MEMKW+1,1           YES, FAKE SELECT
         CLI   MEMKW+1,0           'SELECT/EXCLUDE' SPECIFIED
         BE    NOMEM               NEITHER, BRANCH
         SPACE
         LA    R4,VERDCBW
         MVC   0(VERDCBL,R4),VERDCB
         MVC   DDNAM(8,R4),DDUT2
         CLI   MEMKW+1,1           SELECT
         BNE   NOVER               NO, MUST BE EXCLUDE
         CLI   REPKW+1,2           REP
         BE    NOVER               YES, NO NEED TO VERIFY
         TM    DSORG2,X'02'        IS OUTPUT A PDS
         BZ    NOVER               NO, MUST HAVE SPECIFIED UNLOAD
         LA    R1,OPEN
         MVI   0(R1),X'80'
         OPEN  ((R4),INPUT),MF=(E,(1))
NOVER    EQU   *
         LA    R4,MEM              POINT TO SELECT PDE
         TM    MEMDSPDE+6,X'80'    WAS MEMBER SPECIFIED WITH INPUT DSN
         BZ    *+8                 NO
         LA    R4,MEMDSPDE         YES, FAKE SELECT PDE
CARDLOOP MVC   CARD+1(79),CARD
         MVC   CARD+1(4),=C'S M='
         CLI   MEMKW+1,2
         BNE   *+8
         MVI   CARD+1,C'E'
         LA    R15,CARD+5
         SPACE
MEMLOOP  EQU   *
         TM    6(R4),X'80'         MEMBER PRESENT
         BZ    MEMEND              NO, BRANCH (NEVER HAPPENS)
         TM    14(R4),X'80'        NEWNAME PRESENT
         BZ    NONEW1              NO, SKIP NEXT 2 INSTR
         MVC   0(2,R15),=C'(('     YES
         LA    R15,2(,R15)         YES
NONEW1   LH    R1,4(,R4)           GET LENGTH OF MEMBER NAME
         L     R14,0(,R4)          POINT TO MEMBER NAME
         BCTR  R1,0
         B     *+10
         MVC   0(0,R15),0(R14)     (EXECUTED)
         EX    R1,*-6
         MVC   MEMNAME,0(R15)      SAVE NAME PADDED WITH BLANKS
         MVC   NEWNAME,0(R15)      NEWNAME IS SAME SO FAR
         TM    14(R4),X'80'        IS MEMBER:NEWNAME SPECIFIED
         BZ    NONEW2              NO, USE OLD NAME
         LA    R15,1(R1,R15)       POINT PAST MEMBER NAME
         MVI   0(R15),C','
         LA    R15,1(,R15)
         LH    R1,12(,R4)          GET LENGTH OF NEW NAME
         L     R14,8(,R4)          POINT TO NEW NAME
         BCTR  R1,0
         B     *+10
         MVC   0(0,R15),0(R14)     (EXECUTED)
         EX    R1,*-6
         MVC   NEWNAME,0(R15)      SAVE NAME PADDED WITH BLANKS
         LA    R15,1(R1,R15)       POINT PAST MEMBER NAME
         MVC   0(2,R15),=C'))'     APPEND PARENS
NONEW2   LA    R15,NEWNAME
         BAL   R14,VERIFY          ISSUE MSG IF IT WONT BE COPIED
         PUT   (R6),CARD
         CLI   16(R4),X'FF'
         L     R4,16(,R4)
         BNE   CARDLOOP
MEMEND   EQU   *
         LA    R4,VERDCBW
         TM    OFLGS(R4),X'10'     IS OUTPUT PDS OPEN FOR VERIFY
         BNO   MEMX                NO, BRANCH
         MVI   CLOSE,X'80'
         CLOSE ((R4)),MF=(E,CLOSE)
         B     MEMX
         SPACE
VERIFY   LA    R1,VERDCBW          POINT TO DCB FOR OUTPUT PDS
         TM    OFLGS(R1),X'10'     ARE WE VERIFYING MEMBERS
         BNO   0(,R14)             NO, RETURN
         ST    R14,VERREGS         YES, SAVE RETURN ADDRESS
         MVC   VERBLDL(4),=AL2(1,12) FILL IN BLDL PARAMETER
         MVC   VERBLDL+4(8),0(R15) PUT MEMBER NAME IN BLDL PARAMETER
         BLDL  (1),VERBLDL
         LTR   R15,R15             DOES MEMBER ALREADY EXIST
         BNZ   VERIFYX             NO, SHOULD COPY OK
*        ISSUE MESSAGE - MEMBER ALREADY EXISTS - WONT BE COPIED
         MVI   MSGWK,C' '
         MVC   MSGWK+1(L'MSGWK-1),MSGWK
         MVC   MSGWK(6),=C'MEMBER'
         LA    R1,MSGWK+7
         MVC   0(8,R1),VERBLDL+4
         CLI   0(R1),C' '
         BE    *+12
         LA    R1,1(,R1)
         B     *-12
         MVC   1(L'MSG04,R1),MSG04
         LA    R0,L'MSG04+16
         LA    R1,MSGWK
         BAL   R14,PUTLINE
VERIFYX  L     R14,VERREGS
         BR    R14
         SPACE
NOMEM    CLI   REPKW+1,2           REP
         BE    MEMX                YES, EVERYTHING WILL BE COPIED
         LA    R1,MSG09            WARN USER ABOUT IDENTICAL NAMES
         LA    R0,L'MSG09
         BAL   R14,PUTMSG
         LA    R1,MSG09A           WARN USER ABOUT IDENTICAL NAMES
         LA    R0,L'MSG09A
         BAL   R14,PUTMSG
MEMX     MVI   CLOSE,X'80'
         CLOSE ((R6)),MF=(E,CLOSE)
         SPACE
************************************************************
*                                                          *
*        ALLOCATE THE SYSPRINT FILE (DUMMY)                *
*                                                          *
************************************************************
         SPACE
         CLI   PRINTKW+1,0
         BNE   *+8
         MVI   PRINTKW+1,1         DEFAULT PRINT
         SPACE
         CLI   PRINTKW+1,4         'NOPRINT' SPECIFIED?
         BNE   PRINTERM            NO
         MVC   DA08CD(84),MODEL08
         OI    DA08CTL,DA08DMMY
         BAL   R14,CALLDAIR
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDPRINT,DA08DDN
         B     PRINTX
         DROP  R5                  DAPB08
         SPACE
************************************************************
*                                                          *
*        ALLOCATE THE SYSPRINT FILE TO THE TERMINAL        *
*                                                          *
************************************************************
         SPACE
PRINTERM CLI   PRINTKW+1,1         PRINT
         BNE   PRINTSYS
*        USING DAPB1C,R5
*        MVC   DA1CCD(MODEL1CL),MODEL1C
*        BAL   R14,CALLDAIR
*        LTR   R15,R15
*        BNZ   ERRDAIR
*        MVC   DDPRINT,DA1CDDN
*        DROP  R5                  DAPB1C
*
*         REPLACE DAIR WITH SVC 99
*
         MVC   W99RB(20),T99RB
         MVC   W99RTDDN(14),T99RTDDN
         MVC   W99TERM(4),T99TERM
         LA    R15,W99TUPL
         ST    R15,W99RB+8
         LA    R14,W99RTDDN
         ST    R14,0(,R15)
         LA    R14,W99TERM
         ST    R14,4(,R15)
         MVI   4(R15),X'80'
         LA    R0,W99RB
         ST    R0,W99RBP
         OI    W99RBP,X'80'
         LA    R1,W99RBP
         SVC   99
         LTR   R15,R15
         BNZ   ERRS99
         MVC   DDPRINT,W99RTDDN+6
*
         B     PRINTX
         SPACE
PRINTSYS CLI   PRINTKW+1,2         SYSOUT
         BNE   PRINTOUT
         USING DAPB30,R5
         MVC   DA30CD(MODEL30L),MODEL30
         BAL   R14,CALLDAIR
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDPRINT,DA30DDN
         MVI   FREEOPT,1           FREE DDPRINT WITH CLASS
         DROP  R5                  DAPB30
         B     PRINTX
         SPACE
PRINTOUT CLI   PRINTKW+1,3         OUTFILE
         BNE   PRINTX              NO, USE SYSPRINT
         LA    R4,OUT
         TM    6(R4),X'80'         OUTFILE PRESENT?
         BZ    PRINTX              NO, USE SYSPRINT
         LH    R1,4(,R4)           GET LENGTH
         L     R15,0(,R4)
         MVC   DDPRINT,=CL8' '
         BCTR  R1,0
         B     *+10
         MVC   DDPRINT(0),0(R15)
         EX    R1,*-6
         MVI   FREEOPT,2           DO NOT FREE DDPRINT
         B     PRINTX
         SPACE
PRINTX   EQU   *
         SPACE
************************************************************
*                                                          *
*        ALLOCATE SYSUT3 AND SYSUT4                        *
*                                                          *
************************************************************
         SPACE
         LA    R5,MYDAPB           POINT TO DAIR PARAMETER BLOCK
         USING DAPB08,R5
         MVC   DA08CD(84),MODEL08  MOVE 08 MODEL DAPB
         MVC   DA08UNIT,@UNITVIO
         MVI   DA08PQTY+3,10       10 TRACKS
         MVI   DA08DSP1,DA08NEW
         OI    DA08CTL,DA08TRKS
         BAL   R14,CALLDAIR
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDUT3,DA08DDN
         SPACE
         MVC   DA08CD(84),MODEL08  MOVE 08 MODEL DAPB
         MVC   DA08UNIT,@UNITVIO
         MVI   DA08PQTY+3,10       10 TRACKS
         MVI   DA08DSP1,DA08NEW
         OI    DA08CTL,DA08TRKS
         BAL   R14,CALLDAIR
         LTR   R15,R15
         BNZ   ERRDAIR
         MVC   DDUT4,DA08DDN
         DROP  R5                  DAPB08
         SPACE
************************************************************
*                                                          *
*         ENQ ON OUTPUT PDS                                *
*                                                          *
************************************************************
         SPACE
         MVI   QNAME,0             INDICATE DEQ NOT REQUIRED
         LA    R4,DDUT2            POINT TO OUTPUT DDNAME
         BAL   R14,TIOTSCAN
         LA    R1,0(,R1)           CLEAR HI ORDER BYTE
         ST    R1,UCBAD            SAVE UCB ADDRESS
         CLI   18(R1),X'20'        DASD
         BNE   ENQX                NO, SERIALIZATION NOT REQUIRED
         MVC   QNAME,=CL8'SPFEDIT'
         MVC   DEQ(12),DEQZ
         SPACE
************************************************************
*                                                          *
*         IF DEVICE NOT SHARED, ISSUE ENQ                  *
*                                                          *
************************************************************
         SPACE
         TM    17(R1),X'20'        SHARED DASD
         BO    SHARED              YES, RESERVE REQUIRED
         MVC   ENQ(12),ENQZ
         SPACE
         ENQ   (QNAME,RNAME,E,44,SYSTEMS),RET=NONE,                    +
               MF=(E,ENQ)
         SPACE
         B     ENQX
         SPACE
************************************************************
*                                                          *
*         IF DEVICE SHARED, ISSUE RESERVE                  *
*                                                          *
************************************************************
         SPACE
SHARED   MVC   RESERVE(16),RESZ
         RESERVE (QNAME,RNAME,E,44,SYSTEMS),UCB=UCBAD,RET=NONE,        +
               MF=(E,RESERVE)
         SPACE
ENQX     EQU   *
         SPACE
************************************************************
*                                                          *
*        BUILD IEBCOPY PARAMETERS                          *
*                                                          *
************************************************************
         SPACE
         LA    R1,PARMPTR
         LA    R15,PARMLEN
         ST    R15,0(,R1)
         LA    R15,DDNAMES
         ST    R15,4(,R1)
         OI    4(R1),X'80'
         LA    R14,88
         STH   R14,0(,R15)
         SPACE
************************************************************
*                                                          *
*         INVOKE IEBCOPY                                   *
*                                                          *
************************************************************
         SPACE
         L     R14,16             CVTPTR
         L     R14,X'09C'(,R14)   CVTTVT-CVTMAP
         CLC   0(4,R14),=C'TSVT'  IF TSO/E SYSTEM
         BE    TSOE                  GO CALL TSO SERVICE ROUTINE
         MVC   LINKEP,=CL8'IEBCOPY'
         CLI   IEBKW+1,1           IEBCOPY REQUESTED
         BE    *+10                YES
         MVC   LINKEP(3),=C'SPF'   NO, USE DEFAULT SPFCOPY
         SPACE
         LINK  EPLOC=LINKEP,SF=(E,LINKAREA)
         SPACE
         LR    R4,R15
         CLI   QNAME,0             IF DEQ NOT REQUIRED
         BE    NODEQ1                 SKIP DEQ
         DEQ   (QNAME,RNAME,44,SYSTEMS),MF=(E,DEQ)
NODEQ1   LTR   R15,R4
         BZ    EXIT0
         B     ERRCOPY
         SPACE
TSOE     MVC   TSRPARM1(4),=X'00000002'  NO DUMP, PROGRAM
         MVC   TSRPARM2(8),=CL8'IEBCOPY'
         MVC   TSRPARM3(4),=F'8'  LENGTH OF PROGRAM NAME
         LA    R1,TSRPARMS
         LA    R0,TSRPARM1
         ST    R0,0(,R1)
         LA    R0,TSRPARM2
         ST    R0,4(,R1)
         LA    R0,TSRPARM3
         ST    R0,8(,R1)
         LA    R0,TSRPARM4
         ST    R0,12(,R1)
         LA    R0,TSRPARM5
         ST    R0,16(,R1)
         LA    R0,TSRPARM6
         ST    R0,20(,R1)
         LA    R0,PARMPTR
         ST    R0,24(,R1)
         OI    24(R1),X'80'       7TH AND LAST TSR PARAMETER
         L     R14,16             CVTPTR
         L     R14,X'09C'(,R14)   CVTTVT-CVTMAP
         L     R15,X'010'(,R14)   TSVTASF-TSVT
         BALR  R14,R15            CALL IKJEFTSR
         LR    R4,R15
         CLI   QNAME,0             IF DEQ NOT REQUIRED
         BE    NODEQ2                 SKIP DEQ
         DEQ   (QNAME,RNAME,44,SYSTEMS),MF=(E,DEQ)
NODEQ2   LTR   R15,R4
         BZ    EXIT0
         C     R15,=F'4'           IF RC IS IN TSRPARM4
         BNE   TSRNOT4                THEN
         L     R15,TSRPARM4           GET RC INTO R15
         B     ERRCOPY                GO DISPLAY RC FROM IEBCOPY
TSRNOT4  C     R15,=F'8'
         BE    TSRATTN
         C     R15,=F'12'
         BE    TSRABEND
         C     R15,=F'20'
         BE    TSRERROR
         B     EXIT12
TSRATTN  LA    R1,=C'ATTENTION'
         LA    R0,9
         SVC   93
         B     EXIT12
         SPACE
TSRABEND LA    R1,=C'ABEND'
         LA    R0,5
         SVC   93
         B     EXIT12
         SPACE
TSRERROR L     R14,TSRPARM5
         C     R14,=F'40'
         BE    TSRNOTF
         LA    R1,=C'TSR ERROR'
         LA    R0,9
         SVC   93
         B     EXIT12
TSRNOTF  LA    R1,=C'IEBCOPY NOT FOUND'
         LA    R0,17
         SVC   93
         B     EXIT12
         SPACE
************************************************************
*                                                          *
*         CALL DYNAMIC ALLOCATION                          *
*                                                          *
************************************************************
         SPACE
CALLDAIR LR    R8,R14
         LA    R1,MYDAPL
         AIF   (NOT &MVS).SKIP5
         L     R15,16              CVTPTR
         TM    X'02DC'(R15),X'80'  IF HI ORDER BIT NOT ON
         BNO   DAIRLINK               THEN DO LINK, NOT CALL
         L     R15,X'02DC'(,R15)   CVTDAIR
         BALR  R14,R15             CALL IKJDAIR
         B     DAIREXIT            SKIP AROUND LINK
DAIRLINK EQU   *
.SKIP5   ANOP
         LINK  EP=IKJDAIR,SF=(E,LINKAREA)
DAIREXIT EQU   *
         LR    R14,R8
         BR    R14
         SPACE
************************************************************
*                                                          *
*        DYNAMIC ALLOCATION FAILURE ROUTINE                *
*                                                          *
************************************************************
         SPACE
DAIRFAIL ST    R14,MYDFREGS
         AIF   (NOT &MVS).SKIP6
         LA    R1,MYDFPARM
         USING DFDSECTD,R1
         ST    R15,MYDFRC
         LA    R15,MYDFRC
         ST    R15,DFRCP
         LA    R15,MYDAPL
         ST    R15,DFDAPLP
         SLR   R15,R15
         ST    R15,MYJEFF02
         LA    R15,MYJEFF02
         ST    R15,DFJEFF02
         LA    R15,DFDAIR
         STH   R15,MYDFID
         LA    R15,MYDFID
         ST    R15,DFIDP
         ST    R2,DFCPPLP
         LINK  EP=IKJEFF18,SF=(E,LINKAREA)
         L     R15,MYDFRC
         DROP  R1                  DFDSECTD
.SKIP6   AIF   (&MVS).SKIP7
         LA    R1,MSGDAIR
         LA    R0,L'MSGDAIR
         BAL   R14,PUTMSG
.SKIP7   ANOP
         L     R14,MYDFREGS
         BR    R14
         SPACE
************************************************************
*                                                          *
*        CUU - GET UCB ADDRESS FOR A GIVEN VOLUME          *
*                                                          *
************************************************************
         SPACE
CUU      LR    0,14                SAVE RETURN ADDRESS
         L     14,16               CVTPTR
         TM    116(R15),X'80'      MVS/XA                          .XA.
         BO    UCBXA               YES                             .XA.
         L     14,X'28'(,14)       CVTILK2
CUU1     LH    15,0(,14)           LOAD UCB ADDRESS
         LTR   15,15               VALID ADDRESS?
         BZ    CUU2                NULL - TRY NEXT
         BM    CUU3                END OF LIST
         CLI   18(15),X'20'        DASD?
         BNE   CUU2                NO - TRY NEXT
         TM    3(15),X'80'         ONLINE?
         BZ    CUU2                NO - TRY NEXT
         CLC   28(6,15),0(1)       DOES VOLUME SERIAL MATCH?
         BNE   CUU2                NO - TRY NEXT
         LR    14,0                RESTORE RETURN ADDRESS
         BR    14                  RETURN
CUU2     LA    14,2(,14)           INCREMENT UCB POINTER
         B     CUU1                CONTINUE
CUU3     SLR   15,15               CLEAR UCB POINTER
         LR    14,0                RESTORE RETURN ADDRESS
         BR    14                  RETURN
UCBXA    ST    R0,RETUCB           SAVE RETURN ADDRESS             .XA.
         MVC   VOLNAME(6),0(R1)    SAVE VOLUME NAME                .XA.
         LA    R1,DEVPARMS                                         .XA.
         LA    R14,DEVWORK                                         .XA.
         ST    R14,0(,R1)          1ST ARG IS WORK AREA            .XA.
         XC    0(100,R14),0(R14)   INITIALIZE WORK AREA            .XA.
         LA    R14,DEVCLASS                                        .XA.
         ST    R14,4(,R1)          2ND ARG IS CLASS                .XA.
         MVI   0(R14),X'20'        UCB3DACC (DASD UCB'S)           .XA.
         LA    R14,DEVUCBAD                                        .XA.
         ST    R14,8(,R1)          3RD ARG IS WORD FOR UCB ADDRESS .XA.
         OI    8(R1),X'80'         3RD ARG IS LAST ARG             .XA.
UCBLOOPX LA    R1,DEVPARMS                                         .XA.
         L     R14,16              CVTPTR                          .XA.
         L     R15,X'434'(,R14)    CVTUCBSC V(IOSVSUCB)            .XA.
         BALR  R14,R15             CALL IOSVSUCB                   .XA.
         LTR   R15,R15             IF NO MORE UCB'S                .XA.
         BNZ   UCBLOOPY               GO SET R15=0                 .XA.
         L     R15,DEVUCBAD                                        .XA.
         TM    3(R15),X'80'        ONLINE                          .XA.
         BZ    UCBLOOPX                                            .XA.
         CLC   28(6,R15),VOLNAME   DOES VOLUME MATCH?              .XA.
         BNE   UCBLOOPX            NO - BRANCH                     .XA.
         L     R14,RETUCB          GET RETURN ADDRESS              .XA.
         BR    R14                 RETURN TO CALLER                .XA.
UCBLOOPY SLR   R15,R15             INDICATE UCB NOT FOUND          .XA.
         L     R14,RETUCB          GET RETURN ADDRESS              .XA.
         BR    R14                 RETURN TO CALLER                .XA.
         SPACE
************************************************************
*                                                          *
*        ERROR HANDLERS                                    *
*                                                          *
************************************************************
         SPACE
ERRNODSN LA    R1,MSG06
         LA    R0,L'MSG06
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
ERRMIX   LA    R1,MSG07
         LA    R0,L'MSG07
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
ERRMIX2  LA    R1,MSG08
         LA    R0,L'MSG08
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
ERRMEM   LA    R1,MSG02
         LA    R0,L'MSG02
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
ERRS99   LA    R1,MSGS99
         LA    R0,L'MSGS99
         BAL   R14,PUTMSG
         B     EXIT12
         SPACE
ERRDAIR  BAL   R14,DAIRFAIL
         B     EXIT12
         SPACE
ERRPDS   LA    R15,MSGWK
         BAL   R14,DSNOUT
ERRPDSC  MVC   0(30,R15),=CL30' IS NOT A PARTITIONED DATA SET'
         LA    R15,30(,R15)
         LA    R1,MSGWK
         LR    R0,R15
         SR    R0,R1
         BAL   R14,PUTMSG
         B     EXIT12
ERRPD2   LA    R15,MSGWK
         BAL   R14,DSNOU2
         B     ERRPDSC
         SPACE
ERRCOPY  CVD   R15,DOUBLE
         LA    R15,MSGWK
         BAL   R14,DSNOUT
         MVC   0(21,R15),=CL21' COPYPDS RETURN CODE'
         LA    R15,21(,R15)
         MVI   0(R15),C' '
         UNPK  1(3,R15),DOUBLE+6(2)
         OI    3(R15),X'F0'
         CLI   1(R15),C'0'
         BNE   *+14
         MVC   1(2,R15),2(R15)
         MVI   3(R15),C' '
         CLI   1(R15),C'0'
         BNE   *+14
         MVC   1(2,R15),2(R15)
         MVI   3(R15),C' '
         LA    R15,4(,R15)
         LA    R1,MSGWK
         LR    R0,R15
         SR    R0,R1
         BAL   R14,PUTLINE
         B     EXIT12
         SPACE
DSNOUT   LH    R1,DSNAME
         BCTR  R1,0
         B     *+10
         MVC   0(0,R15),DSNAME+2
         EX    R1,*-6
         LA    R15,1(R1,R15)
         BR    R14
         SPACE
DSNOU2   LH    R1,DSNAM2
         BCTR  R1,0
         B     *+10
         MVC   0(0,R15),DSNAM2+2
         EX    R1,*-6
         LA    R15,1(R1,R15)
         BR    R14
         SPACE
************************************************************
*                                                          *
*        PUTMSG ROUTINE                                    *
*                                                          *
************************************************************
         SPACE
PUTMSG   STM   R14,R1,MYREGS
         XC    MYOLD(8),MYOLD
         XC    MYSEG1(4),MYSEG1
         MVC   MYPTPB(12),MODLPTPM
         LA    R14,1               NO. OF MESSAGE SEGMENTS
         ST    R14,MYOLD
         LA    R14,MYSEG1          POINT TO 1ST SEGMENT
         ST    R14,MYOLD+4
         LR    R14,R0              LENGTH IN R0
         LA    R14,4(,R14)         ADD 4
         LA    R15,MYSEG1+4
         CLC   0(3,R1),=C'IKJ'     IS DATA PRECEEDED BY MESSAGE ID?
         BE    *+16                YES - BRANCH
         LA    R14,1(,R14)         ADD 1 TO LENGTH
         MVI   0(R15),C' '         INSERT LEADING BLANK
         LA    R15,1(,R15)         BUMP POINTER
         STH   R14,MYSEG1
         LR    R14,R0
         BCTR  R14,0
         B     *+10
         MVC   0(0,R15),0(R1)      MOVE MESSAGE IN
         EX    R14,*-6
         LA    R1,MYIOPL
         L     R15,MYPUTLEP
         SPACE
         PUTLINE PARM=MYPTPB,OUTPUT=(MYOLD),ENTRY=(15),MF=(E,(1))
         SPACE
         LM    R14,R1,MYREGS
         BR    R14
         SPACE
************************************************************
*                                                          *
*        PUTLINE ROUTINE                                   *
*                                                          *
************************************************************
         SPACE
PUTLINE  STM   R14,R1,MYREGS
         XC    MYSEG1(4),MYSEG1
         MVC   MYPTPB(12),MODLPTPB
         LR    R14,R0              LENGTH IN R0
         LA    R14,4(,R14)         ADD 4
         STH   R14,MYSEG1
         LR    R14,R0
         BCTR  R14,0
         B     *+10
         MVC   MYSEG1+4(0),0(R1)   MOVE TEXT IN
         EX    R14,*-6
         LA    R1,MYIOPL
         L     R15,MYPUTLEP
         SPACE
         PUTLINE PARM=MYPTPB,OUTPUT=(MYSEG1,DATA),ENTRY=(15),MF=(E,(1))
         SPACE
         LM    R14,R1,MYREGS
         BR    R14
         SPACE
EXIT12   LA    R15,12
         B     EXIT
         SPACE 1
EXIT0    SR    R15,R15             RETURN CODE ZERO
EXIT     LR    R2,R15              HOLD RETURN CODE
         IKJRLSA MYANS
         DROP  R3
         SPACE
         USING DAPB18,R5
         CLI   DDUT1,0
         BE    FFUT1
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDUT1
         BAL   R14,CALLDAIR
FFUT1    EQU   *
         CLI   DDUT2,0
         BE    FFUT2
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDUT2
         BAL   R14,CALLDAIR
FFUT2    EQU   *
         CLI   DDUT4,0
         BE    FFUT4
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDUT4
         BAL   R14,CALLDAIR
FFUT4    EQU   *
         CLI   DDUT3,0
         BE    FFUT3
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDUT3
         BAL   R14,CALLDAIR
FFUT3    EQU   *
         CLI   DDIN,0
         BE    FFIN
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDIN
         BAL   R14,CALLDAIR
FFIN     EQU   *
         CLI   DDPRINT,0
         BE    FFPRINT
         CLI   FREEOPT,2           OUTFILE
         BE    FFPRINT             YES, LEAVE ALLOCATED
         MVC   DA18CD(MODEL18L),MODEL18
         MVC   DA18DDN,DDPRINT
         CLI   FREEOPT,1           SYSOUT?
         BNE   *+8                 NO
         MVI   DA18SCLS,C'A'       YES
         BAL   R14,CALLDAIR
FFPRINT  EQU   *
         DROP  R5                  DAPB18
         TM    MYPUTLEP,X'80'      WAS PUTLINE LOADED
         BO    DELPUTLX            NO, BRANCH
         LA    R0,=CL8'IKJPUTL'    YES, DELETE IT
         DELETE EPLOC=(0)
DELPUTLX EQU   *
         LTR   R2,R2               IS RC ZERO?
         BZ    STACKDX             YES, BRANCH
         MVC   MYSTPB(STACKDL),STACKD
         SPACE
         STACK DELETE=ALL,PARM=MYSTPB,MF=(E,MYIOPL)
         SPACE
         TCLEARQ
STACKDX  EQU   *
EXITX    LR    R15,R2              RESTORE RETURN CODE
         LR    1,R13               SET UP FREE ADDRESS
         L     R13,4(,R13)         RESTORE PREVIOUS SAVEAREA
         ST    R15,16(,R13)        STORE RETURN CODE FOR LM
         L     R0,@SIZE
         FREEMAIN R,A=(1),LV=(0)
         LM    14,12,12(R13)       LOAD RETURN ADDRESS AND RC
         BR    14                  RETURN
         SPACE
************************************************************
*                                                          *
*        CONSTANTS                                         *
*                                                          *
************************************************************
         SPACE
MODLPTPM PUTLINE OUTPUT=(1,TERM,SINGLE,INFOR),                         X
               TERMPUT=(EDIT,WAIT,NOHOLD,NOBREAK),MF=L
         SPACE
MODLPTPB PUTLINE OUTPUT=(1,TERM,SINGLE,DATA),                          X
               TERMPUT=(EDIT,WAIT,NOHOLD,NOBREAK),MF=L
         SPACE
@UNITVIO DC    CL8'SYSDA '         SYSUT3 AND SYSUT4 UNIT NAME
MODEL08  DC    AL2(8),XL10'0',CL24' ',XL16'0',CL16' ',XL8'0',CL8' '
MODEL08L EQU   *-MODEL08
MODEL18  DC    X'0018',XL10'0',CL18' ',XL2'0',CL8' '
MODEL18L EQU   *-MODEL18
MODEL1C  DC    X'001C',XL6'0',CL16' '
MODEL1CL EQU   *-MODEL1C
MODEL30  DC    X'0030',XL10'0',CL24' ',XL12'0',CL14' ',XL2'0',CL8' '
MODEL30L EQU   *-MODEL30
         SPACE
MSG01    DC    C'PARSE ERROR'
MSG02    DC    C'- ERROR - A MEMBER NAME WAS SPECIFIED FOR COPYPDS'
MSG03    DC    C'OUTPUT DATA SET MAY NOT BE SAME AS INPUT'
MSG04    DC    C'ALREADY EXISTS - WILL NOT BE COPIED'
MSG05    DC    C'UNABLE TO OBTAIN DSCB FOR OUTPUT DATA SET'
MSG06    DC    C'IKJ58509I DATA SET NAME REQUIRED WHEN MEMBER IS SPECIF+
               IED'
MSG07    DC    C'EXCLUDE NOT PERMITTED WHEN DSNAME(MEMBER) SPECIFIED'
MSG08    DC    C'DSNAME2(MEMBER) NOT PERMITTED WITHOUT DSNAME1(MEMBER)'
MSG09    DC    C'WARNING: IDENTICALLY NAMED MEMBERS WILL NOT BE COPIED'
MSG09A   DC    C'AND THERE WILL BE NO INDICATION IF THAT HAPPENS'
MSGDAIR  DC    C'UNABLE TO ALLOCATE'
MSGS99   DC    C'UNABLE TO ALLOCATE TERMINAL'
         LTORG
         PRINT NOGEN
CTLDCB   DCB   DDNAME=DYNAM,DSORG=PS,MACRF=PM,BUFNO=2,                 +
               RECFM=FB,LRECL=80,BLKSIZE=800
CTLDCBL  EQU   *-CTLDCB
VERDCB   DCB   DDNAME=DYNAM,DSORG=PO,MACRF=R
VERDCBL  EQU   *-VERDCB
         PRINT GEN
DDNAM    EQU   40
OFLGS    EQU   48
         SPACE
OBTAIN   CAMLST SEARCH,2,3,4
OBTAINL  EQU   *-OBTAIN
         SPACE
STACKD   STACK DELETE=ALL,MF=L
STACKDL  EQU   *-STACKD
         SPACE
ENQZ     ENQ   (Q,R,E,44,SYSTEMS),MF=L
RESZ     RESERVE (Q,R,E,44,SYSTEMS),UCB=U,MF=L
DEQZ     DEQ   (Q,R,44,SYSTEMS),MF=L
Q        EQU   0                   DUMMY OPERAND
R        EQU   0                   DUMMY OPERAND
U        EQU   0                   DUMMY OPERAND
         SPACE
T99RB    DC    0F'0',X'14016000',A(0,0,0,0)
T99RTDDN DC    X'0055',X'0001',X'0008',CL8' '
T99TERM  DC    X'0028',X'0000'
         DC    0D'0'
         SPACE
************************************************************
*                                                          *
*        PARSE PCL                                         *
*                                                          *
************************************************************
         SPACE
         PRINT NOGEN
COMPRPCL IKJPARM
DSN      IKJPOSIT DSNAME,USID,PROMPT='DATA SET NAME',                  +
               HELP='INPUT DATA SET NAME'
DS2      IKJPOSIT DSNAME,USID,PROMPT='DATA SET NAME',                  +
               HELP='OUTPUT DATA SET NAME'
MEMKW    IKJKEYWD
         IKJNAME 'SELECT',SUBFLD=MEMSF
         IKJNAME 'EXCLUDE',SUBFLD=MEMSF
REPKW    IKJKEYWD
         IKJNAME 'ADD'
         IKJNAME 'REPLACE'
IUNIKW   IKJKEYWD
         IKJNAME 'IUNIT',SUBFLD=IUNISF
OUNIKW   IKJKEYWD
         IKJNAME 'OUNIT',SUBFLD=OUNISF
IVOLKW   IKJKEYWD
         IKJNAME 'IVOLUME',SUBFLD=IVOLSF
OVOLKW   IKJKEYWD
         IKJNAME 'OVOLUME',SUBFLD=OVOLSF
OSHRKW   IKJKEYWD
         IKJNAME 'OLD'
         IKJNAME 'SHR'
         IKJNAME 'OSHR'
PRINTKW  IKJKEYWD
         IKJNAME 'PRINT'
         IKJNAME 'SYSOUT'
         IKJNAME 'OUTFILE',SUBFLD=OUTSF
         IKJNAME 'NOPRINT'
IEBKW    IKJKEYWD
         IKJNAME 'IEBCOPY'
LISTKW   IKJKEYWD
         IKJNAME 'NOLIST'
         IKJNAME 'LIST'
         IKJNAME 'L'
LOADKW   IKJKEYWD
         IKJNAME 'LOAD'
UNLOKW   IKJKEYWD
         IKJNAME 'UNLOAD'
MEMSF    IKJSUBF
MEM      IKJIDENT 'MEMBER NAME',LIST,RANGE,                            +
               FIRST=ALPHA,OTHER=ALPHANUM,MAXLNTH=8,                   +
               PROMPT='MEMBER NAME'
IUNISF   IKJSUBF
IUNI     IKJIDENT 'UNIT',FIRST=ALPHANUM,OTHER=ANY,MAXLNTH=8,           +
               PROMPT='UNIT NAME FOR INPUT PDS'
OUNISF   IKJSUBF
OUNI     IKJIDENT 'UNIT',FIRST=ALPHANUM,OTHER=ANY,MAXLNTH=8,           +
               PROMPT='UNIT NAME FOR OUTPUT PDS'
IVOLSF   IKJSUBF
IVOL     IKJIDENT 'VOLUME',FIRST=ALPHANUM,OTHER=ALPHANUM,MAXLNTH=6,    +
               PROMPT='VOLUME SERIAL FOR INPUT PDS'
OVOLSF   IKJSUBF
OVOL     IKJIDENT 'VOLUME',FIRST=ALPHANUM,OTHER=ALPHANUM,MAXLNTH=6,    +
               PROMPT='VOLUME SERIAL FOR OUTPUT PDS'
OUTSF    IKJSUBF
OUT      IKJIDENT 'OUTFILE FILENAME',                                  +
               FIRST=ALPHA,OTHER=ALPHANUM,MAXLNTH=8,                   +
               PROMPT='OUTFILE FILENAME'
         IKJENDP
         PRINT GEN
         SPACE
************************************************************
*                                                          *
*        DSECTS                                            *
*                                                          *
************************************************************
         SPACE
TIOT     DSECT
         DS    CL24                JOBNAME, ETC
TIOENTRY DS    0C
TIOELNGH DS    AL1                 LENGTH OF THIS ENTRY
         DS    XL3
TIOEDDNM DS    CL8                 DD NAME
TIOEJFCB DS    CL3                 TTR OF JFCB
         DS    XL2
TIOEFSRT DS    AL3                 ADDRESS OF UCB
         SPACE
@DATA    DSECT
         DS    18F                 REGISTER SAVEAREA
DOUBLE   DS    D
LINKAREA DS    2F
LINKEP   DS    0CL8
MYPPL    DS    7F
MYANS    DS    F
MYECB    DS    F                  USED BY PUTLINE ROUTINE
MYIOPL   DS    4F                 USED BY PUTLINE ROUTINE
MYPTPB   DS    3F                 USED BY PUTLINE ROUTINE
MYPUTLEP DS    F                  USED BY PUTLINE ROUTINE
MYOLD    DS    2F                 USED BY PUTLINE ROUTINE
MYSEG1   DS    2H,CL100           USED BY PUTLINE ROUTINE
MYREGS   DS    4F                 USED BY PUTLINE ROUTINE
MYDFREGS DS    F
MYSTPB   DS    0F                 USED BY STACK DELETE (5F)
MYDAPL   DS    5F
MYDAPB   DS    21F
DSNAME   DS    H,CL44
DSNAM2   DS    H,CL44
RNAME    EQU   DSNAM2+2
MEMNAME  DS    CL8
NEWNAME  DS    CL8
MEMDSPDE DS    5F                 FAKE SELECT PDE
MYDFPARM DS    5F  USED BY DAIRFAIL
MYDFRC   DS    F   USED BY DAIRFAIL
MYJEFF02 DS    F   USED BY DAIRFAIL
MYDFID   DS    H   USED BY DAIRFAIL
*
FREEOPT  DS    H
*
PARMPTR  DS    2F,H
PARMLEN  DS    H
PARM     DS    0F,H
DDNAMES  DS    H,CL32
DDIN     DS    CL8
DDPRINT  DS    CL8
         DS    CL8
DDUT1    DS    CL8
DDUT2    DS    CL8
DDUT3    DS    CL8
DDUT4    DS    CL8
*
MSGWK    DS    CL72
OPEN     DS    0F
CLOSE    DS    F
CTLDCBW  DS    0D,(CTLDCBL)X
VERDCBW  DS    0D,(VERDCBL)X
VERREGS  DS    F
VERBLDL  DS    2H,CL8,CL4
DSORG1   DS    C
DSORG2   DS    C
OBTVOL   DS    CL6
OBTAINW  DS    4F
TSRPARMS DS    7F
TSRPARM1 DS    F
TSRPARM2 DS    CL8
TSRPARM3 DS    F
TSRPARM4 DS    F
TSRPARM5 DS    F
TSRPARM6 DS    F
*
QNAME    DS    CL8
UCBAD    DS    F
ENQ      DS    3F
RESERVE  DS    4F
DEQ      DS    4F
*
DEVPARMS DS    3F
DEVCLASS DS    C
VOLNAME  DS    CL6
DEVUCBAD DS    F
DEVWORK  DS    25F
RETUCB   DS    F
*
DSCB     DS    CL140
         DS    0D
CARD     DS    CL80
W99RBP   DS    F
W99RB    DS    5F
W99TUPL  DS    2F
W99RTDDN DS    7H
W99TERM  DS    2H
         DS    0D
@DATAL   EQU   *-@DATA
         SPACE
         IKJCPPL
         SPACE
         IKJIOPL
         SPACE
         IKJPPL
         SPACE
         IKJDAPL
         SPACE
         IKJDAP08
         SPACE
         IKJDAP18
         SPACE
         IKJDAP1C
         SPACE
         IKJDAP30
         SPACE
         AIF   (NOT &MVS).SKIP8
         IKJEFFDF DFDSECT=YES
.SKIP8   ANOP
         SPACE
R0       EQU   0
R1       EQU   1
R2       EQU   2
R3       EQU   3
R4       EQU   4
R5       EQU   5
R6       EQU   6
R7       EQU   7
R8       EQU   8
R9       EQU   9
R10      EQU   10
R11      EQU   11
R12      EQU   12
R13      EQU   13
R14      EQU   14
R15      EQU   15
         END
@@
//LKED.SYSLMOD DD DSN=SYS2.CMDLIB(COPYPDS),UNIT=,SPACE=,DISP=SHR
//LKED.SYSIN   DD DUMMY
//*
//SAMPLIB  EXEC PGM=PDSLOAD
//STEPLIB  DD  DSN=SYSC.LINKLIB,DISP=SHR
//SYSPRINT DD  SYSOUT=*
//SYSUT2   DD  DISP=SHR,DSN=SYS2.HELP
//SYSUT1   DD DATA,DLM=@@
./ ADD NAME=COPYPDS
)F FUNCTION -
  THE COPYPDS COMMAND COPIES AN ENTIRE PDS, OR SELECTED MEMBERS,
  TO ANOTHER PDS.

  THE 'IEBCOPY' UTILITY IS INVOKED.  THE 'SYSPRINT' MESSAGES
  FROM IEBCOPY ARE WRITTEN TO WHEREVER FILENAME(SYSPRINT) IS
  ALLOCATED - USUALLY TO THE TERMINAL.

  COPYPDS ALLOWS YOU TO COPY A MEMBER AND ITS ALIAS, WHICH
  CANNOT BE DONE CORRECTLY WITH THE 'COPY' COMMAND.
  SPECIFY THE MEMBER AND ALIAS NAME IN THE 'SELECT' KEYWORD.
)X SYNTAX  -
         COPYPDS   'DSNAME1'  'DSNAME2'  SELECT('MEMBERS')
                                         ADD/REPLACE SHR LIST
  REQUIRED - 'DSNAME1' 'DSNAME2'
  DEFAULTS - ADD (EXISTING MEMBERS WILL NOT BE REPLACED).
  ALIAS    - NONE
  EXAMPLES -
         HERE ARE 3 WAYS OF COPYING ONE MEMBER:
             COPYPDS X.DATA Y.DATA SELECT(MEM1)
             COPYPDS X.DATA(MEM1) Y.DATA
             COPYPDS X.DATA(MEM1) Y.DATA(MEM1)
         HERE ARE 2 WAYS OF COPYING ONE MEMBER AND RENAMING IT:
             COPYPDS X.DATA Y.DATA SELECT(MEM1:MEM2)
             COPYPDS X.DATA(MEM1) Y.DATA(MEM2)
         TO COPY 2 MEMBERS (OR ONE MEMBER AND ITS ALIAS):
             COPYPDS X.DATA Y.DATA SELECT(MEM1 MEMA)
         TO COPY ALL MEMBERS:
             COPYPDS X.DATA Y.DATA
)O OPERANDS -
  'DSNAME1' -  THE NAME OF THE INPUT PDS.
             A MEMBER NAME MAY BE SPECIFIED WITH THE DSNAME.
  'DSNAME2' -  THE NAME OF THE OUTPUT PDS. IT MUST ALREADY EXIST.
             A NEW DATA SET WILL NOT BE ALLOCATED IF IT DOES NOT EXIST.
             A MEMBER NAME MAY BE SPECIFIED WITH THE DSNAME (UNLESS
             ONE WAS NOT SPECIFIED WITH 'DSNAME1').
))ADD      - ONLY MEMBERS HAVING NAMES DIFFERENT FROM EXISTING MEMBERS
             IN THE OUTPUT PDS WILL BE COPIED.
             IF YOU EXPLICITLY SPECIFIED MEMBER NAMES, COPYPDS WILL
             TELL YOU WHICH ONES WONT BE COPIED.
             IF YOU DID NOT SPECIFY ANY MEMBER NAMES, A WARNING MESSAGE
             WILL BE ISSUED THAT THERE WILL BE NO INDICATION OF WHICH
             MEMBERS WERE NOT COPIED.
))REPLACE  - ALL MEMBERS WILL BE COPIED, EVEN IF IT MEANS REPLACING
             AN EXISTING MEMBER IN THE OUTPUT PDS.
))SELECT('MEMBERS') - RESTRICTS THE COPY TO SPECIFIC MEMBERS.
             MEMBERS CAN BE GIVEN NEW NAMES AS THEY ARE COPIED,
             BY SPECIFYING SELECT(MEMBER1:NEWNAME1 MEMBER2:NEWNAME2).
             THE COLON AND NEWNAME SHOULD BE OMITTED FOR ANY MEMBERS
             THAT ARE TO HAVE THEIR OLD NAME.
))SHR      - THE OUTPUT PDS WILL BE ALLOCATED SHR INSTEAD OF EXCLUSIVE.
             YOU RISK UNPREDICTABLE RESULTS IF ANOTHER JOB OR USER
             IS WRITING IN THE PDS AT THE SAME TIME.
))LIST     - 'LIST=NO' WILL NOT BE PASSED TO IEBCOPY.