|
|
|
|
|
|
|
|
|
|
370 Assembler Language Program Code |
|---|
|
This is program 7 in the system that unloads and restores
DASD between 2 physical locations.
It executes as the second step in the unload
job to dynamically build the restore job
JCL. |
DBR7JCLR START 0
DBR7JCLR AMODE 31
DBR7JCLR RMODE 24
SAVE (14,12)
LR R12,R15
USING DBR7JCLR,R12
LA R11,4095(,R12)
LA R11,1(,R11)
USING DBR7JCLR+4096,R11
ST R0,ADRPSA
B GETTCB
CODE314 DC F'314'
CODE1217 DC F'1217'
*
* The program inputs and processes the following
* DBR7OUT1 = restore data set name for copy 1
* DBR7OUT2 = restore data set name for copy 2
* DBR7BK1 = backup data set name for copy 1
* DBR7BK2 = backup data set name for copy 2
* JNAMREST = character 1 of the restore jobname
* %VOL% = insert the DASD volser where string
* is in the output data set name mask
*
* Get the Task Control Block address and save it
*
GETTCB DS 0H
USING PSA,R0
L R8,PSATOLD
DROP R0
ST R8,ADRTCB
* Get core for the save area and program work area
*
LR R10,R13
L R9,0(R1)
LA R0,WAREAEND-WAREABGN
GETMAIN R,LV=(0),LOC=(BELOW)
LR R13,R1
USING WAREABGN,R13
*
* R13 = Address program save area and program work area
* Chain the save areas and initialize the work area
*
ST R10,WSAVE+4
ST R13,8(R10)
MVC WSNAPBGN,=CL8'WSNAPBGN'
MVC WEND,=CL8'WAREAEND'
LA W2,WXBGN-WAREABGN(,R13)
LA R4,XAREABGN
L R3,=A(WXEND-WXBGN)
LR R5,R3
MVCL R2,R4
LA R2,WEPAAREA-WAREABGN(,R13)
ST R2,WEPAADDR
LA R2,WJCLIN
*
* Set the end of file address
* Initialize the CAMLST macro
*
USING IHADCB,R2
LA R3,EOJCLIN
STCM R3,B'0111',DCBEODAD+1
DROP R2
*
LA R2,WCAMDSN
ST R2,WCAMLST-WAREABGN+CAMDSN(R13)
LA R2,WCAMAREA
ST R2,WCAMLST-WAREABGN+CAMAREA(R13)
EJECT
*
* Register equates
*
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 Base register 2
R12 EQU 12 Base register 1
R13 EQU 13 Program save area and work area address
R14 EQU 14
R15 EQU 15
*
MSG14 DS F
RTN14 DS F
ADRPSA DS A
ADRPARM DS A
*
DBRTABLE DS 0F Where to go table
DC AL1(8),AL1(0),AL2(0),A(PBK1),CL12'DBR7BK1='
DBRENTB DC AL1(8),AL1(DBRNREQ),AL2(0),A(PBK2),CL12'DBR7BK2='
DC AL1(9),AL1(0),AL2(0),A(POUT1),CL12'DBR7OUT1='
DBRENTO DC AL1(9),AL1(DBRNREQ),AL2(0),A(POUT2),
DC CL12'DBR7OUT2
DC AL1(9),AL1(0),AL2(0),A(PJREST),CL12'JNAMREST='
DC AL1(0)
*
DBRPARM DCB DDNAME=DBRPARM,DSORG=PS,MACRF=(GL),EODAD=EOPARM
DBRCLC CLC 0(0,R1),DBRCON-DBRENT(R6)
*
PARMFLAG DC X'00' Indicates 1 or 2 outputs
PARMMISS EQU B'10000000' Required parm missing
*
PARMTRL EQU B'00000001' We are trailing programs
*
PASSFLAG DC X'00"
PASSOUT2 EQU B'10000000' We have 2 output data sets
PASSBK2 EQU B'01000000' We have 2 backup data sets
PASSDUP EQU B'00100000' ON when doing 2 outputs
PASS2 EQU B'00010000' ON when doing 2nd pass
*
SAVOUT1L DC H'0' Restore dsname #1 len
SAVOUT1C DC CL44' ' Restore dsname #1
SAVOUT2L DC H'0' Restore dsname #2 len
SAVOUT2C DC CL44' ' Restore dsname #2
*
SAVBK1L DC H'0' Backup dsname #1 len
SAVBK1C DC CL44' ' Backup dsname #1
SAVBK2L DC H'0' Backup dsname #2 len
SAVBK2C DC CL44' ' Backup dsname #2
*
WRKBK1L DC H'0' Full dsname #1 len
WRKBK1C DC CL44' ' Full dsname #1
WRKBK2L DC H'0' Full dsname #2 len
WRKBK2C DC CL44' ' Full dsname #2
*
*
EJECT
*
* Begin main program processing
*
BEGIN DS 0H
MVI JOB1CHAR,JOB1REST Set default jobname char
OI PARMFLAG,PARMTRL Indicate we are trailing the
OPEN (DBRPARM,(INPUT)) system
*
DBR7GET DS 0H
GET DBRPARM Read a record
ST R1,ADRPARM Save record address
LA R5,DBRPARM Get address data DCB
USING IHADCB,R5 Addressability
LH R5,DCBLRECL Length of input record
DROP R5
*
* Skip comment lines, blank lines and leading blanks
*
DBR7C DS 0H
CLI 0(R1),C'*'
BE DBR7GET
DBR7D DS 0H
CLI 0(R1),C' '
BNE DBR7D1
LA R1,0(,R1)
BCT R5,DBR7D
B DBR7GET
*
* At this point the register contents are as follows:
* R1 = A(1st nonblank character on this record at entry)
* R5 = Remaining number of characters in input record
* R6 = A(DBRTABLE entry)
*
DBR7D1 DS 0H
LA R6,DBRTABLE
USING DBRENT,R6
DBR7E DS 0H
CLI DBRLEN,0 End of table
BE DBR7GET Yes. Get next input
SR R3,R3
IC R3,DBRLEN Length of table parameter
BCTR R3,R0 Minus 1 for CLC
EX R3,DBRCLC Is parameter in table
BE DBR7F Yes.
LA R6,DBRENTL(,R6) No. next table entry
B DBR7E Compare it to the next entry
*
* Branch here when the parameter is in the table
* R5 = Number of characters left in the input record
* R1 = A(first parameter character)
*
DBR7F DS 0H
SR R5,R3 # input bytes-parmlen-1
BCTR R5,R0 -1 from input = parm len
C R5,=A(0) Any input left?
BH DBR7G No. nothing after constant
B DBR7GET nothing after constant
DBR7G DS 0H
LA R1,1(R3,R1) A(last constant char + 1)
L R15,DBRWTG A(routine to process parm)
BALR R14,R15 Go process parm and return
B DBR7GET Get next parm until EOF
*
* Come here when it is the end of the input parm dataset
* Test if any required parameter was missing
* If a required parameter is missing, then it is an error
*
EOPARM DS 0H
CLOSE (DBRPARM)
LA R6,DBRTABLE First entry in parm table
EOPARM1 DS 0H
CLI DBRLEN,0 End of parameter table
BE EOPARM3 Yes. chk for all parms
TM DBRFLAG,DBRIN Was this parameter processed
BO EOPARM2 Yes.
TM DBRFLAG,DBRNREQ No. is this parm required
BO EOPARM2 No. so its OK
BAL R14,DBR7ERR2 Yes. we need this parm
EOPARM2 DS 0H
LA R6,DBRENTL(,R6) Next entry in the table
B EOPARM1
EOPARM3 DS 0H
TM PARMFLAG,PARMMISS Got all required parms
BO CATEXIT No. exit the program
TM PASSFLAG,PASSOUT2+PASSBK2 Want 2 outputs
BNO EOPARMS No. only 1 data set
BM EOPARM4 ON/OFF mixed flags
OI PASSFLAG,PASSDUP ON/ON set duplicate copy
B EOPARMS and parms are done
EOPARM4 DS 0H
TM PASSFLAG,PASSOUT2 Is output only flag on
BNO EOPARM5 No.
LA R6,DBRENTB DBR7BK2= is missing
B EOPARM6
EOPARM5 DS 0H
LA R6,DBRENT0 DBR7OUT2= is missing
EOPARM6 DS 0H
BAL R14,DBR7ERR2 Display missing parm err
WTO 'DBR00020: DBR7OUT2 AND DBR7BK2 ARE REQUIRED FOR
BACKUP DATA SETS'
LA R15,CODE554 End program with RC=554
B CATEXIT
CODE554 EQU 554
*
* This code processes the DBR7OUT1 = parameter to build
* the data set name for the first copy of the restore
* dataset
* At entry to this routine
* R1 = A(parameter character 1)
* R5 = Number of bytes left in the input record
*
POUT1 DS 0H
STM R0,R15,RTNSAVE Save all registers at entry
DBR7OUT DS 0H
LA R2,L'SAVOUT1C Maximum chars in dsname
LA R3,SAVOUT1C Where to move the dsname
SR R4,R4 Clear the length register
DBR7OUT1 DS 0H
STCM R4.B'0011',SAVOUT1L Save data set name length
LTR R5,R5 is the length exhausted
BZ DBR7OUT2 Yes.
CLI 0(R1),C' ' End of input parameter
BE DBR7OUT2 Yes.
LTR R2,R2 Max dsname length reached
BP *+16 No.
BAL R14,DBR7ERR1 Yes. it is an error
LA CODE555 Exit with return code 555
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of the data set
LA R3,1(,R3) +1 to receiving address
LA R1,1(,R1) +1 to sending address
LA R4,1(,R4) +1 to receiving field length
BCTR R2,R0 -1 from maximum dsname len
BCTR R5,R0 -1 from input length
B DBR7OUT1 Loop to process next char
*
* Here after we moved the data set name to add ending
* comma
*
DBR7OUT2 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT1L
LTR R4,R4
BP *+16
BAL R14,DBR7ERR1 Whoops, we have a bad length
LA R15,CODE555 Return with condition code 5
B CATEXIT
MVI 0(R3),C'.' End the name with a period
LA R4,1(,R4) +1 to receiving length
STCM R4,B'0011',SAVOUT1L Save dsname length
LM R0,R15,RTNSAVE Restore the registers
BR R14 and return to the caller
*
* This code processes the DBR7OUT2 = parameter
* to build the data set name for the second restore
* data set, if the user wants 2 copies of output
* data set.
*
POUT2 DS 0H
STM R0,R15,RTNSAVE
DBR7OU2 DS 0H
LA R2,L'SAVOUT2C Max dsname chars allowed
LA R3,SAVOUT2C A(more-to dsname)
SR R4,R4 0 to dsname len
DBR7OU21 DS 0H
STCM R4,B'0011',SAVOUT2L Save data set name length
LTR R5,R5 Is there more input
BZ DBR7OU22 No. input is exhausted
CLI 0(R1),C' ' Input ended with a blank
BE DBR7OU22 Yes.
LTR R2,R2 Max # chars reached
BP *+16 No. not max
BAL R14,DBR7ERR1 Yes. is error
LA R15,CODE555 RC=555
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of dsname
LA R3,1(,R3) A(next dsname char)
LA R1,1(,R1) A(next char in input)
LA R4,1(,R4) +1 moved dsname len
BCTR R2,R0 -1 max dsname len
BCTR R5,R0 -1 input dsname len
B DBR7OU21 Loop next dsname char
DBR7OU22 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT2L Dsname length in R4
LTR R4,R4 Is the length 0
BP *+16 No. len greater than 0
BAL R14,DBR7ERR1 Yes. len <= 0
LA R15,CODE555 Display err msg
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of the dsname
LA R3,1(,R3) +1 to receiving dsname addr
LA R1,1(,R1) +1 to sending dsname addr
LA R4,1(,R4) +1 to receiving dsname len
BCTR R2,R0 -1 from max dsname len
BCTR R5,R0 -1 from input dsname len
B DBR7OU21 Process next dsname char
DBR7OU22 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT2L Length of moved dsname
LTR R4,R4 Is the length 0
BP *+16 No. it is a positive number
BAL R14,DBR7ERR1 Yes. less than or equal to 0
LA R15,CODE555 Is a return code 555 error
B CATEXIT
MVI 0(R3),C'.' Len ok, end name w/period
LA R4,1(,R4) +1 to receiving dsname len
STCM R4,B'0011',SAVOUT2L due to adding the period
OI DBRFLAG,DBRIN Turn on parm done flag
OI PASSFLAG,PASSOUT2 Turn on 2 outputs flag
LM R0,R15,RTNSAVE Restore registers and
SR R15,R15 Set 0 for good return code
BR R14 Return to caller
*
* This code processes the JNAMREST = parameter which has
* the first character of the restore job jobname
*
PJREST DS OH
ST R14,RTN14 Save caller's return address
CLI 1(R1),C' ' Is jobname char +1 blank
BE PJREST1 Yes it is.
BAL R14,DBR7ERR1 No. that is an error
B PJREST2 cuz can only have 1 char
PJREST1 DS 0H
MVC JOB1CHAR,0(R1) Save char 1 of the jobname
OI DBRFLAG,DBRIN Set got jobname char flag
PJREST2 DS 0H
L R14,RTN14 Get callers return address
BR R14 and return to caller
*
* This routine displays error message DBR00011
* for an invalid input parameter
*
DBR7ERR1 DS 0H
ST R14,RTN14 Save callers return address
MVC DBR7MSG1+38(L'DBRCON),DBRCON Move in the con
DBR7MSG1 WTO 'DBR00011: INVALID PARAMETER = XXXXXXXXXXXX' +38
L R14,RTN14 Issue the message and return
BR R14
*
* This routine displays error message DBR00002
* when a required parameter is missing
*
DBR7ERR2 DS 0H
ST R14,RTN14 Display error message,
MVC DBR7MSG2+38(L'DBOCON),DBOCON
DBR7MSG2 WTO 'DBR00002: MISSING PARAMETER - XXXXXXXXXXXX'
OI PARMFLAG,PARMMIS Turn missing parm flag on
L R14,RTN14 and return to caller
BR R14
*
* This routine processes DBR7BK1= parameter and inserts
* the unloaded DASD volume serial number where string
* %VOL% appears in the data set name
*
* For example, while unloading DASD volume serial SYS002,
* if parameter DBR7BK1=UNLOAD.DFDSS.%VOL%.COPY1
* then upon exiting this routine, the data set name will
* have been expanded to
* UNLOAD.DFDSS.SYS002.COPY1
*
* In this routine,
* R1 = A(first character after the equal sign)
* R2 = Max number of chars in save area backup dsname
* R3 = A(Save area backup data set name)
* R4 = Actual length of data set name in the save area
* R5 = Num characters remaining after = sign in input
*
PBK1 DS 0H
STM R0,R15,RTNSAVE Save callers registers
EXTRACT PBKTIOT,'S',FIELDS=TIOT Addr(TIOT)
B DBR7BK
PBKTIOT DS A is stored in this field
DBR7BK DS 0H
LA R2,L'SAVBK1C Max # chars in backup dsname
LA R3,SAVBK1C Data set name move-to addr
SR R4,R4 Clear number of chars moved
L R1,RTNSAVE+4 Restore addr = sign + 1
DBR7BK1 DS 0H
STCM R4,B'0011',SAVBK1L Save data set name length
LTR R5,R5 Any input chars left
BZ DBR7BK20 No. we are finished
CLI O(R1),C' ' Is this end of input
BE DBR7BK20 Yes. a blank also terminates
C R2,=A(0) Did we process max number
BH *+16 No. continue
BAL R14,DBR7ERR1 Yes. not followed by blank
B CATEXIT is an error. Display msg
DBR7BK20 DS 0H
SR R4,R4
ICM R4,B'0011',SAVBK1L Get current dsname length
C R4,=A(0) Is it zero?
BH *+16 Greater than 0, continue
VOL1ERR DS 0H
BAL R14,DBR7ERR1 It is 0, display error msg
LA R15,CODE555
B CATEXIT
VOL1 DS 0H
LA R3,SAVBK1C Address backup data set name
LA R2,L'VOLSTG-1 Length of %VOL% string - 1
S R4,=A(L'VOLSTG) Addr last possible char
MVI WRKBK1C,C' ' Blanks to receiving data set
MVC WRKBK1C+1(L'WRKBK1C-1),WRKBK1C
XC WRKBK1L,WRKBK1L 0 to receiving data set name
LA R6,WRKBK1C A(expanded data set name)
*
* Look for string %VOL% in the parameter data set name
*
VOL1A DS 0H
EX R2,VOLCLC Does string %VOL% start here
BE VOL1B Yes. we found the string
MVC 0(1,R6),0(R3) No. move a char of the data
LA R3,1(,R3) +1 to input backup data set
LA R6,1(,R6) +1 to moved backup dsn addr
BCT R4,VOL1A Keep looking for %VOL% stg
B VOL1ERR
*
* Here when we find string %VOL% in the parameter data
* R3 = Addr 1st character of string %VOL% is save area
* R6 = Addr 1st blank character in the move-to work area
* This program runs as the second step of the unload job
* the unload DASD volume serial number is in characters
* d-8 of the unload jobname.
*
VOL1B DS 0H
L R14,VOL1B31
BSM R0,R15 Switch to 31 bit addressing
VOL1B31 DC A(VOL1B31A+X'80000000')
VOL1B31A DS 0H
L R15,PBKTIOT Restore address of TIOT
USING TIOT1,R15 base in register 15
MVC O(L'VOLSER,R6),TIOCNJOB+2 Move volser
DROP R15 to where %VOL% appears
L R15,VOL1B24
BSM R0,R15 Switch back to 24 bit addr
VOL1B24 DC A(VOL1B24A)
VOL1B24A DS 0H
*
* Move the rest of the data set name from input
* to the first char past the unload volume serial number
*
LA R6,L'LVOLSER(,R6) Continue moving
LA R3,L'VOLSTG(,R3) Past %VOL% string
S R4,=A(L'VOLSTG-1) -5 from character count
C R4,=A(0) Is char count a positive num
BNH VOL1ERR No. we have an error
VOL1C DS 0H
CLI O(R3),C' ' Is there a blank
BE VOL1EXIT Yes. finished with dsname
MVC 0(1,R6),0(R3) No. move next char of dsname
LA R3,1(,R3) +1 to input dsname address
LA R6,1(,R6) +1 to data set name in work
B VOL1C Continue looking for end
*
* Here when we have the end of the input parameter dsname
*
VOL1EXIT DS 0H
SR R15,R15 0 in register 15
LH R15,SAVBK1L Length of input parm dsname
S R15,=A(L'VOLSTG) Minus len of %VOL% string
A R15,=A(L'LVOLSER) Plus the len of volser
STH R15,WRKBK1L Save the new data set name l
STH R15,SAVBK1L in save and work areas
BCTR R15,R0 We are moving new name
MVI SAVBK1C,C' ' the save area after we clear
MVC SAVBK1C+1(L'SAVBK1C-1),SAVBK1C
EX R15,VOLMVC Here goes move to save area
VOL1EXI2 DS 0H
L R6,RTNSAVE+(4*R6) Restore address to reg 6
OI DBRFLAG,DBRIN Turn on 'parm is finished'
LM R0,R15,RTNSAVE Restore the callers register
SR R15,R15 Set 0 return code in reg 15
BR R14 and return to caller
*
VOLCLC CLC 0(0,R3),VOLSTG
VOLMVC MVC SAVBK1C(*-),WRKBK1C
*
* This routine processes input parameter DBR7BK2= when 2
* output copies of the unload data set are requested
* using similar logic as that which processed parm
* DBR7BK1=
*
* In this routine,
* R1 = A(first character after the equal sign)
* R2 = Maximum number of chars in save area backup data
* R3 = A(Save area backup data set name)
* R4 = Actual length of data set name in the save area
* R5 = # characters remaining after = sign in input
*
PBK2 DS 0H
STM R0,R15,RTNSAVE Save callers register
EXTRACT PBKTIOT2'S',FIELDS=TIOT Addr of Task IO Table
B DBR7BK
PBKTIOT2 DS A is stored in this field
DBR7PBK DS 0H
LA R2,L'SAVBK2C Maximum # chars backup dsn
LA R3,SAVBK2C Data set name move-to addr
SR R4,R4 Clear number of chars moved
L R1,RTNSAVE+4 Restore addr = sign + 1
DBR7PBK1 DS 0H
STCM R4,B'0011',SAVBK2L Save data set name length
LTR R5,R5 Any input chars left
BZ DBR7PBK2 No. we are finished
CLI O(R1),C' ' Is this end of input
BE DBR7PBK2 Yes. a blank also terminates
C R2,=A(0) Did we process the max #
BH *+16 No. continue
BAL R14,DBR7ERR1 Yes. not followed by blank
LA R15,CODE555
B CATEXIT is an error. Display msg
DBR7PBK2 DS 0H
SR R4,R4
ICM R4,B'0011',SAVBK2L Current data set name len
C R4,=A(0) Is it zero?
BH *+16 It is greater than 0, loop
*
VOL2ERR DS 0H
BAL R14,DBR7ERR1 It is 0, display error msg
LA R15,CODE555
B CATEXIT
VOLPBK1 DS 0H
LA R3,SAVBK2C Address backup data set name
LA R2,L'VOLSTG-1 Length of %VOL% string - 1
S R4,=A(L'VOLSTG) Address last possible char
MVI WRKBK2C,C' ' Blanks to receiving data set
MVC WRKBK2C+1(L'WRKBK2C-1),WRKBK2C
XC WRKBK2L,WRKBK2L 0 to receiving data set name
LA R6,WRKBK2C A(expand dsname)
*
* Look for string %VOL% in the parameter data set name
*
VOLPBK2A DS 0H
EX R2,VOLCLC Does string %VOL% start here
BE VOLPBK2B Yes. we found the string
MVC 0(1,R6),0(R3) No. move a char of the data
LA R3,1(,R3) +1 to input backup data set
LA R6,1(,R6) +1 to moved backup dsname
BCT R4,VOLPBK2A Keep looking for %VOL% stg
B VOL2ERR
*
* Here when we find string %VOL% in the parameter data
* R3 = Address 1st char of string %VOL% is save area
* R6 = Addr 1st blank character in the move-to work area
* This program runs as the second step of the unload job
* Unload DASD volume serial number is in characters 3-8
* of the unload jobname.
*
VOLPBK2B DS 0H
L R14,VOL2PB31
BSM R0,R15 Switch to 31 bit addressing
VOL2PB31 DC A(VOL2P31A+X'80000000')
VOL2P31A DS 0H
L R15,PBKTIOT2 Restore address of TIOT
USING TIOT1,R15 base in register 15
MVC O(L'VOLSER,R6),TIOCNJOB+2 Move volser from unload
DROP R15 to where %VOL% appears
L R15,VOL2PB24
BSM R0,R15 Switch back to 24 bit addr
VOL2PB24 DC A(VOL2P24A)
VOL2P24A DS 0H
*
* Move the rest of the data set name from the input parm
* to the first char past the unload volume serial number
*
LA R6,L'LVOLSER(,R6) Continue moving remainder
LA R3,L'VOLSTG(,R3) Past %VOL% string
S R4,=A(L'VOLSTG-1) Subtract 5 from char cnt
C R4,=A(0) Is char count a positive num
BNH VOL2ERR No. we have an error
VOLPBK1C DS 0H
CLI O(R3),C' ' Is there a blank at end
BE VOL2EXIT Yes. we are finished
MVC 0(1,R6),0(R3) No. move next char of dsname
LA R3,1(,R3) +1 to input dsname address
LA R6,1(,R6) +1 to data set name in work
B VOLPBK1C Continue looking for end
*
* Here when we have the end of the input parameter dsname
*
VOL2EXIT DS 0H
SR R15,R15 0 in register 15
LH R15,SAVBK2L Length of input parm dsname
S R15,=A(L'VOLSTG) Minus len of %VOL% string
A R15,=A(L'LVOLSER) Plus the len volser
STH R15,WRKBK2L Save the new data set name l
STH R15,SAVBK2L in save and work areas
BCTR R15,R0 We are going to move name
MVI SAVBK2C,C' ' the save area after we clear
MVC SAVBK2C+1(L'SAVBK2C-1),SAVBK2C
EX R15,VOLMVC2 Here goes the move
VOL2EXI2 DS 0H
L R6,RTNSAVE+(4*R6) Restore address to reg 6
OI DBRFLAG,DBRIN Turn on 'parm is finished'
LM R0,R15,RTNSAVE Restore the callers register
SR R15,R15 Set 0 return code in reg 15
BR R14 and return to caller
*
VOLMVC2 MVC SAVBK2C(*-*),WRKBK2C
*
DROP R2 End DBRTABLE addressability
*
* Here after we have processed the parameters in
*
EOPARMS DS 0H
L R15,SEC1B
BSM R0,R15 Switch to 31 bit addressing
SEC1B DC A(SEC1BX+X'80000000')
SEC1BX DS 0H
*
* Here for each output data set whether it be 1 or 2
* backup copies
*
LOOPPASS DS 0H
L R8,ADRTCB Get address of Task Ctlblk
USING TCB,R8
*
L R8,TCBJSCB Get address of Job Step
DROP R8 Control Block
USING IEZJSCB,R8
*
SR R7,R7
ICM R7,B'0111',JSCBJCTA
DROP R8
*
LA R8,WEPAAREA
USING ZB505,R8
STCM R7,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP Change to Supervisor State
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
STM R0,R15 Save all registers
MODESET MODE=PROB Change to Problem Program Sta
*
LTR R15,R15 Test register 15 return code
BZ *+8 It is good, continue
ABEND 2,DUMP It is bad, ABEND
*
L R7,SWBLKPTR
USING INJMJCT,R7
SR R6,R6
ICM R6,B'0111',JCTSDKAD
DROP R7
*
LOOPSCT DS 0H
XC SWBLKPTR(LAB505),SWBLKPTR
STCM R6,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP Back to supervisor mode for
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB then back to problem program
LTR R15,R15
BZ *+8 Continue on good return code
ABEND 3,DUMP Else abend at this spot
*
L R7,SWBLKPTR
USING INSMSCT,R7
SR R6,R6
ICM R6,B'0111',SCTFSIOT
LOOPSIOT DS 0H
XC SWBLKPTR(LZB404),SWBLKPTR
STCM R6,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R15)
*
MODESET MODE=SUP
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB
LTR R15,R15
BZ *+8
ABEND 4,DUMP
*
L R6,SWBLKPTR
USING INDMSIOT,R6
SR R5,R5
ICM R5,B'0111',SCTPJFCB
XC SWBLKPTR(LZB505),SWBLKPTR
STCM R5,B'0111',SWVA
LA R2,WSWQREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB
L R5,SWBLKPTR
ST R5,WSAVJFCB Save Job File Control Block
USING INFMJFCB,R5
MVC WDSNM,JFCBDSNM Move JFCB data set name into
TM PASSFLAG,PASS2 Are we on output copy 2
BO *+14 Yes.
MVC WRKBK1C,JFCBDSNM No. we are on output copy 1
B *+10
MVC WRKBK2C,JFCBDSNM We are on output copy 2
TM PASSFLAG,PASS2
BO *+18
CLC SAVBK1C,WRKBK1C Compare output copy 1 dsnames
BNE NEXTSIOT They do not match get next na
B BUNAME They match, continue
CLC SAVBK2C,WRKBK2C Compare output copy 2 dsnames
BNE NEXTSIOT No match, get next data set
B BUNAME
*
* Here after we have the backup data set name from the
* operating system control blocks and it matches the
* name in the work area
*
BUNAME DS 0H
MVI WDSNM,C' ' Blanks to data set name
MVC WDSNM+1(L'WDSNM-1),WDSNM
LA R2,WDSNM
LA R3,JFCBDSNM
LA R4,L'WDSNM 0 to data set name length in
SR R1,R1
STC R1,WDSNML
BULOOP1 DS 0H
CLI O(R3),C' ' Look for blank at end of data
BE BULOOP1X
MVC 0(1,R2),O(R3) Move dsname 1 char at a time
LA R1,1(,R1) +1 to data set name length
LA R2,1(,R2) +1 to work area data set name
LA R3,1(,R3) +1 to JFCB data set name addr
BCT R4,BULOOP1 -1 from maximum data set name
BULOOP1X DS 0H
*
* Read the job JCL mask and save each JCL statement in
* GETMAIN area
*
L R15,SW01A
BSM R0,R15 Switch to 24 bit addressing
SW01A DC A(SW01AX) for sequential input/output
SW01AX DS 0H
LA R3,WJCLIN Address of the input data
LA R1,WOPENIN
OPEN ((R3),(INPUT)),MODE=24,MF=(E,(1)) open the data
L R15,sw02a
BSM R0,R15 Back to 31 bit addressing
SW02A DC A(SW02AX+X'80000000')
SW02AX DS 0H
LA R1,WJCLIN Input DCB address in Reg 1
USING IHADCB,R1
MVC WAVLRECL,DCBLRECL Input record length
DROP R1
LH R0,WAVLRECL Get logical record length in
GETMAIN R,LV=(0),LOC=(BELOW) Get memory for 1 input
ST R1,WJCLWORK Save memory address
BUGET DS 0H
LA R1,WJCLIN
GET (R3) Get a JCL mask statement
LR R3,R1 Card input address in Reg 3
L R15,SW04B
BSM R0,R15 Back to 31 bit addressing
SW04B DC A(SW04BX+X'80000000')
SW04BX DS 0H
LH R4,WAVLRECL Number bytes in a JCL mask
LA R4,LJCLDSEC(,R4) + number of bytes in rec
GETMAIN R,LV=((R4)),LOC=(BELOW)
USING JCLDSECT,R1
BCTR R4,R0 -1 from logical rec ctlblk
EX R4,WCAREA clear logical record control
LR R4,R1 block
*
* At this point the register contents are:
* R1 = Address current JCL image control block
* R3 = Address input JCL mask statement
* R4 = Address new jcl image control block
* This code chains the JCL mask control blocks together
*
CLC WJCL,=A(0) First time through
BNE BUGET1 No.
ST R4,WJCL Save getmain address 1st time
B BUGET4
BUGET1 DS 0H Here when it is not the first
L R1,WJCL
BUGET2 DS 0H
L R2,JCLNEXT
LTR R2,R2 Addr next JCL mask
BZ BUGET3
LR R1,R2
B BUGET2 Looking for last JCL mask
BUGET3 DS 0H
ST R4,JCLNEXT Chain new image to last image
LR R0,R1 Last completed control block
LR R1,R4 Make new image current
ST R0,JCLPREV Addr previous image
BUGET4 DS 0H
LH R4,WAVLRECL Logical record length again
BCTR R4,R0 Minus 1
EX R4,WMVCJCL Move input JCL mask to ctlblk
L R14,WRKSEQ +1 to JCL mask input count
LA R14,1(,R14)
ST R14,JCLSEQ
ST R14,WRKSEQ
DROP R1
B BUGET Go processing next JCL mask
*
* Here after reading all JCL masks into control blocks
*
EOJCLIN DS 0H
L R15,SW05C
BSM R0,R15 Switch to 24 bit addressing
SW05C DS A(SW05CX)
SW05CX DS 0H
LA R3,WJCLIN
CLOSE ((R3)),MODE=24,MF=(E,(1)) Close JCL mask input
L R15,SW06C
BSM R0,R15 Switch to 31 bit addressing
SW06C DC A(SW06CX+X'80000000')
SW06CX DS 0H
CLC WJCL,=A(0) Was the JCL mask file empty
BNE GOTJCL No. we read 'some' JCL masks
WTO 'DBR00012: JCLIN DATA SET EMPTY' Yes. display err
LA R15,CODE4
B CATEXIT and exit
*
* Here after reading all JCL masks and closing dataset
*
GOTJCL DS 0H
L R1,WJCL Addr 1st JCL mask in the chai
USING JCLDSECT,R1
*
* Previously we built the data set name
* Here we build the JCL for the restore job
*
SCANJCL DS 0H
LA R3,INSTBL Addr of insert table
USING INSDSECT,R3
*
SCANSTR DS 0H
LA R1,JCLIMAGE Start of JCL image
LH W4,WAVLRECL JCL image length
SR R9,R9
IC R9,INSLEN Get the string length
BCTR R9,R0 -1 from insert string length
SR R4,R9 -insert stg len-1 from JCL im
SCANCHAR DS 0H
EX R9,WCLCINS Look for the keyword
BE SCANHIT We found a keyword
LA R2,1(,R2) No hit. Addr next
BCT R4,SCANCHAR Keep on looking
LA R3,LINSENT(,R3) Addr next keyword in table
CLC INSWTG,=A(0) Are there more JCL masks?
BNZ SCANSTR Yes. look for next keyword
*
* Here when there is no keyword in the JCL mask and/or
* a keyword has been inserted into the JCL mask
*
LOOPJCL DS 0H
L R1,JCLNEXT Addr next JCL mask ctlblk
LTR R1,R1 Or was that the last JCL mask
BNZ SCANJCL No. there are more JCL masks
B SCANDONE Yes. all done
*
* Here when we find a keyword in the JCL mask
* Register usage is:
* R1 = Address JCL image control block
* R2 = Address first char of keyword string, which is %
* R5 = Address Job File Control Block
* R9 = Length of keyword string - 1
*
SCANHIT DS 0H
L R15,INSWTG Get keyword routine address
BALR R14,R15 Go to keyword routine
LTR R15,R15 Routine end with good return
BZ LOOPJCL Yes. keep going til all mask
ABEND (15),DUMP No. Abend program
DROP R3
*
NEXTSIOT DS 0H
SR R1,R1
ICM R1,B'0111',SCTPSIOT
LTR R1,R1
BZ NEXTSCT
LR R6,R1
B LOOPSIOT
*
NEXTSCT DS 0H
SR R1,R1
ICM R1,B'0111',SCTANSCT
LTR R1,R1
BZ SCTDONE
LR R6,R1
B LOOPSCT
SCTDONE DS 0H
LA R15,CODE0 End program with good rc
B CATEXIT
*
DROP R5
DROP R6
DROP R7
DROP R8
*
* Here when all JCL masks have been processed
*
SCANDONE DS 0H
*
* Allocate the output partitioned data set that contains
* restore job JCL for all DASD volumes in this shipment
* Use SVC 99 to dynamically allocate the dataset.
* RESERVE restore JCL dataset device to prevent
* multiple programs from updating it simultaneously and
* 'clobbering' it. When the DASD device is reserved,
* write the restore job to shipment's restore ds
*
SVC99 DS 0H
LA R15,W99RBPTR
USING S99RBP,R14
LA R2,W99RB
ST R2,S99RBPTR
OI S99RBPTR,S99TUPLN
DROP R14
*
LA R14,W99RB
USING S99RB,R14
LA R2,W99TUPTR
ST R2,S99TXTPP
DROP R14
*
LR R14,R2
USING S99TUPL,R14
LA R2,WALDSNAM
ST R2,S99TUPTR
MVI WDSNAME,C' '
MVC WDSNAME+1(L'WDSNAME-1),WDSNAME
TM PASSFLAG,PASS2 Are we on copy 2 of 2
BO *+16 Yes.
LA R5,SAVOUT1C No. we are on the 1st copy
LH R6,SAVOUT1L
B *+12
LA R5,SAVOUT2C
LH R6,SAVOUT2L
BCTR R6,R0 -1 from length
LA R15,WDSNAME
EX R6,MVCDSN
B *+10
MVCDSN MVC 0(*-*,R15),0(R5)
LA R15,1(R6,R15) Addr where to put shipment
MVC 0(L'WDSNSUF,R15),WDSNSUF ID which is A-Z
LA R15,1(,R15) +1 for shipment ID
LA R6,WDSNAME
SR R15,R6 Calculate dsname length
STCM R15,B'0011',WDSNAMEL and save it
*
LA R14,L'S99TUPTR(,R14)
LA R2,WALSTATS
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALNDISP Addr DISP=x parameter
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALCDISP Addr DISP=(.,x) parameter
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALDDNAM Addr DDNAME parameter
ST R2,S99TUPTR
OI S99TUPTR,S99TUPLN Last parameter flag
*
LA R2,W99RB SVC 99 request block
USING S99RB,R2
XC S99FLAG1,S99FLAG1 Clear the flag bytes
XC S99ERROR,S99ERROR
XC S99INFO,S99INFO
XC S99FLAG2,S99FLAG2
DROP R2
*
LA R1,W99RBPTR
SVC 99 Allocate restore JCL ds
LTR R15,R15 Did we allocate it
BZ SVCOK Allocated restore JCL ds
CVD R15,WDOUBLE No. convert the return code
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC SVCWTO+29(3),WDOUBLE Put return code in error msg
LA R2,W99RB
USING S99RB,R2
MVC HEXCHAR,S99INFO Convert SVC99 information
NI HEXCHAR,X'F0' from hexadecimal to char
TR HEXCHAR,HEXTBL by translating the first 4
MVC SVCWTO+41(1),HEXCHAR bits
MVC HEXCHAR,S99INFO and by translating the last
NI HEXCHAR,X'0F' in the first info byte
TR HEXCHAR,HEXTBL
MVC SVCWTO+42(1),HEXCHAR
MVC HEXCHAR,S99INFO+1 and then doing the same to
NI HEXCHAR,X'F0' second info byte
TR HEXCHAR,HEXTBL in order to display the info
MVC SVCWTO+43(1),HEXCHAR in the error msg.
MVC HEXCHAR,S99INFO+1
NI HEXCHAR,X'0F'
TR HEXCHAR,HEXTBL
MVC SVCWTO+44(1),HEXCHAR
*
MVC HEXCHAR,S99ERR0R Now translate the error code
NI HEXCHAR,X'F0' from hexadecimal to
TR HEXCHAR,HEXTBL character
MVC SVCWTO+55(1),HEXCHAR Move translated bits to err
MVC HEXCHAR,S99ERROR
NI HEXCHAR,X'0F' Do same for last 4 bits
TR NEXCHAR,HEXTBL
MVC SVCWTO+56(1),HEXCHAR And move to error msg
MVC HEXCHAR,S99ERROR+1
NI HEXCHAR,X'F0' Isolate 1st 4 bits of error
TR HEXCHAR,HEXTBL byte 2
MVC SVCWTO+57(1),HEXCHAR
MVC HEXCHAR,S99ERROR+1 Isolate last 4 bits of error
NI HEXCHAR,X'0F' byte 2
TR HEXCHAR,HEXTBL
MVC SVCWTO+58(1),HEXCHAR
MVC SVCWTO1+18(L'RNAMEDSN),RNAMEDSN Dsname errmsg
*
SVCWTO WTO 'DBR00003: SVC 99 R15=XXX,S99INFO=XXXX,S99ERROR=C
XXXX'
SVCWTO1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
ABEND CODE532,DUMP End the program with a dump
CODE532 EQU 532
*
* We are here because we successfully allocated
* this shipment's restore JCL partitioned data set (PDS).
* Now we have to RESERVE the DASD device the JCL PDS
* so only 1 program at a time can write to the file.
*
SVCOK DS 0H
L R15,SW07D Switch to 24 bit addressing
SW07D DC A(SW07DX)
SW07DX DS 0H
LA R2,ADDRTIOT TIOT address
EXTRACT ((R7)),FIELDS=TIOT TIOT table address
L R7,ADDRTIOT
LA R7,24(,R7)
NEXTDD DS 0H
CLC WRESERVE(LWRESERV),4(R7)
BE FINDUCB
SR R1,R1
IC R1,0(R7)
CLC 0(4,R7),=F'0'
BNE NEXTDD Could not find restore
ABEND 200,DUMP dataset UCB
*
FINDUCB DS 0H
LA R8,16(,R7)
L R8,0(R8)
LA R8,0(R8) We found the UCB for
ST R8,ADDRUCB device the restore dataset
USING UCBOB,R8 is on
LR R9,R8
S R9,=A(UCBPRFX) Subtract UCB prefix length
USING UCB,R9
CLI UCBID,UCBSTND Is this a standard UCB
BE STDUCB
ABEND 400,DUMP No. abend
* Here when we have a standard UCB (unit control block)
*
STDUCB DS 0H
TM PASSFLAG,PASS2 Are we on the second output
BO STDUCB1 Yes.
MVC RNAMEDSN,SAVOUT1C No. 1st copy, move dsname
LH R15,SAVOUT1L Len of dsname
B STDUCB2
STDUCB1 DS 0H
MVC RNAMEDSN,SAVOUT2C Yes. move dsname for copy 2
LH R15,SAVOUT2L
STDUCB2 DS 0H
LA R7,RNAMEDSN
LA R7,0(R15,R7)
MVC O(L'WDSNSUF,R7),WDSNSUF Use shipment #
RESERVE (QNAME,RNAME,E,0,SYSTEMS),RET=HAVE,UCB=ADDRUCB
LTR R15,R15 Did we successfully RESERVE
BZ RESVOK Yes.
SR R7,R7 No. put return code in error
IC R7,E(R15) message
LR R15,R7
CVD R15,WDOUBLE
OI WDOUBLE+7,X'0F'
UNPK RWTOR2A+47(8),WDOUBLE+3(5)
MVC RWTO42AA+18(L'RNAMEDSN),RNAMEDSN Move data set
RWTOR2A WTO 'DBR00021: RESERVE RET=HAVE RETURN CODE=XXXXXXX'
RWTOR2AA WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
B STOWDONE
*
* We successfully reserved the DASD device the restore
* restore JCL dataset in on. Everyone else locked out
* Open the restore JCL shipment data set
*
RESVOK DS 0H
MVC RESVOKM+27(L'RNAMEDSN),RNAMEDSN move dsname
RESVOKM WTO 'DBR00022: RESERVED XXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXX'
LA R3,WJCLOUT
LA R1,WOPENOUT
OPEN ((R3),(OUTPUT)),MODE=24,MF=(E,(1)) open the JCL
L R15,SW08D dataset
BSM R0,R15
SW08D DC A(SW08DX+X'80000000')
SW08DX DS 0H
L R9,WJCL Get address first JCL stmt
USING JCLDSECT,R9
*
* Now ... we are going to write the job JCL to the
* restore JCL partitioned data set one line at a time
*
PUTJCL DS 0H
L R15,SW09E
BSM R0,R15
SW09E DC A(SW09EX)
SW09EX DS 0H
LA R8,JCLIMAGE-JCLDSECT(,R9) position to JCL
LA R3,WJCLOUT statement
LH R7,WAVLRECL
USING IHADCB,R3
STH R7,DCBBLKSI Set the blocksize in the DCB
DROP R3
WRITE DECBOUT,SF,((R3)),((R8)),((R7)) there it goes
CHECK DECBOUT Test the WRITE return code
L R15,SW10D
BSM R0,R15
SW10D DC A(SW10D+X'80000000')
SW10DX DS 0H
*
* After the JCL is written out, STOW the member name
* in the partitioned data set directory
*
WRTOK DS 0H
STOWPDS DS 0H
L R15,SW11D
BSM R0,R15
SW11D DC A(SW11DX)
SW11DX DS 0H
LA R3,WJCLOUT
STOW ((R3)),PDSENT,A First try to ADD the name
LTR R15,R15 Did we do it?
BNZ STOWAERR No. we had an error
MVC STOWAMSG+18(L'PDSNAME),PDSNAME issue msg
MVC STOWAMSG+36(L'RNAMEDSN),RNAMEDSN
WTO 'DBR00023: XXXXXXXX ADDED TO XXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXXXXXXXXXXX'
B STOWDONE We're rolling now ...
*
* Display this message when the STOW macro failed
*
STOWAERR DS 0H
CVD R15,WDOUBLE Translate return code
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWAWTO+36(3),WDOUBLE
CVD R0,WDOUBLE
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWAWTO+43(3),WDOUBLE
MVC STOWAWTO+18(L'PDSNAME),PDSNAME
MVC STOWAWT1+18(L'RNAMEDSN),RNAMEDSN)
STOWAWTO WTO 'DBR00025: XXXXXXXX STOW R15=XXX R0=XXX NOT ADDED
STOWAWT1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
STOWREP DS 0H If we couldn't add it, re
LA WJCLOUT
STOW ((R3)),PDSENT,R
LTR R15,415 Did we replace it?
BNZ STOWRERR No. we did not replace it
*
* If we replaced the JCL member, issue this message
*
MVC STOWRMSG+18(L'PDSNAME),PDSNAME
MVC STOWRMSG+39(L'RNAMEDSN),RNAMEDSN
STOWRMSG WTO 'DBR00024: XXXXXXXX REPLACED IN XXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXXXXXXXXXXXXXX'
B STOWDONE We have the restore job n
*
* We are here because we could not add OR replace restore
* JCL member in this shipment's partitioned data set
*
STOWRERR DS 0H
CVD R15,WDOUBLE Retcode in error msg
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWRWTO+36(3),WDOUBLE
CVD R0,WDOUBLE
OI WDOUBLE+7,X'0F' Turn the sign bit on
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWRWTO+43(3),WDOUBLE+6(2)
MVC STOWRWTO+18(L'PDSNAME),PDSNAME
MVC STOWRWT1+18(L'RNAMEDSN),RNAMEDSN
STOWRWTO WTO 'DBR00026: XXXXXXXX STOW R15=XXX R0=XXX NOT REPLC
ACED'
STOWRWT1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
*
* We were either successful or unsuccessful in writing
* restore job JCL in the restore shipment JCL data set.
* Regardless, CLOSE the restore shipment JCL data set and
* release the DASD volume it is on from the RESERVE
*
STOWDONE DS 0H
LA R1,WCLS
LA R3,WJCLOUT
CLOSE ((R3)),MODE=24,MF=(E,(1))
DEQRES DS 0H
DEQ (QNAME,RNAME,0,SYSTEMS),RET=HAVE,UCB=ADDRUCB
LTR R15,R15 Release good
BZ DEQOK Yes
SR R7,R7 No
IC R7,3(R15) It will be released when
LR R15,R7 program ends
CVD R15,WDOUBLE Add DEQ return code to
OI WDOUBLE+7,X'0F' err msg
UNPK RWTOR3A+35(8),WDOUBLE+3(5)
MVC RWTOR3AA+18(L'RNAMEDSN),RNAMEDSN
RWTOR3A WTO 'DBR00027: DEQ RETURN CODE=XXXXXXXX IGNORED'
RWTOR3AA WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
*
DEQOK DS 0H Tell operator we release
MVC DEQWTOK+27(L'RNAMEDSN),RNAMEDSN
DEQWTOK WTO 'DBR00028: DEQUEUED XXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXX'
L R15,SW12D
BSM R0,R15
SW12D DC A(SW12DX+X'80000000')
SW12DX DS 0H
DROP R9
*
* We are finished with writing out the JCL, closed the
* data set we wrote it to and, released the DASD volume
* the data set was on
*
TM PASSFLAG,PASS2 Was this for the second
BO DEQOK1 Yes. we are finished
TM PASSFLAG,PASSDUP No. do we want a second
BNO DEQOK1 No. we only want 1 copy
LA R2,W99BGN Yes. we want 2 copies
LA R4,X99BGN So let's do it again
LA R3,W99END-W99BGN
LA R5,X99END-X99BGN
MVCL R2,R4 Reinit SVC 99 parameters
MVC WJCLIN(XJCLINL),XJCLIN
LA R2,WJCLIN
USING IHADCB,R2
*
LA R3,EOJCLIN
STCM R3,B'0111',DCBEODAD+1 Reinit end-of-JCLIN rtn
DROP R2 address
*
* Deallocate the restore JCL partitioned data set with SV
*
MVC WJCL1,WJCL Save GETMAIN address
XC WJCL,WJCL
MVC WJCLOUT(XJCLOUTL),XJCLOUT
LA R2,WD9RB
ST R2,WD9RBPTR
OI WD9RBPTR,X'80'
LA R2,WD9TU1
ST R2,WD9TXTPP
OI WD9TU1,X'80 Last text unit ptr in
LA R1,WD9RBPTR the list
SVC 99
LTR R15,R15
BZ SVCDOK
*
* Deallocate failed, display error msg with return and
* error codes in it
*
CVD R15,WDOUBLE SVC 99 had a bad return
OI WDOUBLE+7,X'0F' turn on sign bit and
UNPK WDOUBLE(3),WDOUBLE+6(2) unpack
MVC SVCWTOD+29(3),WDOUBLE
LA R2,WD9RB
USING S99RB,R2
*
MVC HEXCHAR,S99INFO Convert SVC99 info code
NI HEXCHAR,X'F0' from hex to character
TR HEXCHAR,HEXTBL translate first 4 bits
MVC SVCWTOD+1(1),HEXCHAR
MVC HEXCHAR,S99INFO and by translating the last
NI HEXCHAR,X'0F' 4 in the first info byte
TR HEXCHAR,HEXTBL
MVC SVCWTOD+42(1),HEXCHAR
MVC HEXCHAR,S99INFO+1 do same to
NI HEXCHAR,X'F0' second info byte
TR HEXCHAR,HEXTBL to display info code
MVC SVCWTOD+43(1),HEXCHAR in the error msg.
MVC HEXCHAR,S99INFO+1
NI HEXCHAR,X'0F'
TR HEXCHAR,HEXTBL
MVC SVCWTOD+44(1),HEXCHAR
*
MVC HEXCHAR,S99ERR0R Now translate the error code
NI HEXCHAR,X'F0' from hexadecimal to print
TR HEXCHAR,HEXTBL characters
MVC SVCWTOD+55(1),HEXCHAR Translated bits to err msg
MVC HEXCHAR,S99ERROR
NI HEXCHAR,X'0F' Do same for last 4 bits
TR NEXCHAR,HEXTBL
MVC SVCWTOD+56(1),HEXCHAR And move to error msg
MVC HEXCHAR,S99ERROR+1
NI HEXCHAR,X'F0' Isolate 1st 4 bits of error
TR HEXCHAR,HEXTBL byte 2
MVC SVCWTOD+57(1),HEXCHAR
MVC HEXCHAR,S99ERROR+1 Isolate last 4 bits of error
NI HEXCHAR,X'0F' byte 2
TR HEXCHAR,HEXTBL
MVC SVCWTOD+58(1),HEXCHAR We have all err info
MVC SVCWTOD1+18(L'RNAMEDSN),RNAMEDSN Dsname to msg
*
SVCWTOD WTO 'DBR00003: SVC 99 R15=XXX S99INFO=XXXX S99ERROR=C
XXXX;'
WTO ' DEALLOCATION FAILED'
ABEND CODE532,DUMP End program with a dump
DROP R2
*
* We successfully deallocated the restore JCL data set
*
SVCDOK DS 0H
MVC RNAMEDSN,SAVOUT2C Move data set name
LH R15,SAVOUT2L Data set name length
LA R7,RNAMEDSN
LA R7,0(,R15,R7) .+1 after dsname INDEX
MVC 0(L'WDSNSUF,R7),WDSNSUF Move shipment number for
B LOOPPASS RESERVE macro
DEQOK1 DS 0H
LA R15,CODE0 DEQ successful
B CATEXIT
*
CODE0 EQU 0 Return code for good end of job
CODE4 EQU 4 JCLIN file was empty
CODE8 EQU 8 Insufficient columns in which to expand
CODE12 EQU 12 Bad program parameter
CODE16 EQU 16 LOCATE macro nonzero RC in byte 3
CODE555 EQU 555 DBRPARM had invalid parameter
EJECT
*
* This is where we exit the program
*
CATEXIT DS 0H
L R2,WSAVE+4
ST R15,16(R2) Save return code
LA R0,WAREAEND-WAREABGN Length of GETMAIN area
LR R1,R13
FREEMAIN R,LV=(0),A=(1) Free the GETMAIN area
LR R13,R2
RETURN (14,12) Return to caller
*
LTORG
*
* The following work areas are not moved to the
* GETMAIN AREA
*
MAXIMAGE EQU 72 Max number columns on a JCL mask stmt
MAXSER EQU 6 Max number output cartridge volsers
* This is the where-to-go table for JCL masks
INSTBL DC V(RTN1),AL1(5),CL11'%DSN%'
DC V(RTN2),AL1(8),CL11'%SERIAL%'
DC V(RTN3),AL1(5),CL11'%JOB%'
DC V(RTN4),AL1(5),CL11'%VOL%'
DC A(0) End of where to go table
*
ADDRTIOT DS F Address of the Task Input/Output Table
ADDRUCB DS F Address of the Unit Control Block
*
QNAME DC CL8'SYSDSN
RNAME DC CL256' '
ORG RNAME
DC X'0B'
RNAMEDSN DC CL44' ' Example: SYS.DFDSS.RESTORE.
ORG RNAME+256
*
HEXCHAR DC C' '
HEXTBL DC C'0123456789ABCDEF'
DC X'F1',C'123456789ABCDEF'
DC X'F2',C'123456789ABCDEF'
DC X'F3',C'123456789ABCDEF'
DC X'F4',C'123456789ABCDEF'
DC X'F5',C'123456789ABCDEF'
DC X'F6',C'123456789ABCDEF'
DC X'F7',C'123456789ABCDEF'
DC X'F8',C'123456789ABCDEF'
DC X'F9',C'123456789ABCDEF'
DC C'A123456789ABCDEF'
DC C'B123456789ABCDEF'
DC C'C123456789ABCDEF'
DC C'D123456789ABCDEF'
DC C'E123456789ABCDEF'
DC C'F123456789ABCDEF'
*
* The following areas are moved to the GETMAIN area
*
XAREABGN DS 0D
DC C'XAREABGN'
XEPAADDR DC A(XEPAAREA)
XEPAAREA DC 4F'0'
XCAMAREA DS 0D
DS CL265' '
XCAMDSN DS CL44' '
XCAMLST CAMLST NAME,XCAMDSN,,XCAMAREA
*
XTIOT DS F
XEXTRACT EXTRACT XTIOT,'S',FIELDS=TIOT,MF=L
*
X99BGN EQU *
X99RBPTR DC A(X99RB)
X99RB DS 0F
X99RBLN DC AL1(20)
X99VERB DC AL1(S99VRBAL)
X99FLAG1 DC AL2(0)
X99ERROR DC AL2(0)
X99INFO DC AL2(0)
X99TXTPP DC AL4(0)
DC AL4(0)
X99FLAG2 DC AL4(0)
*
X99TUPTR DS 0F Text unit addresses
X99TU1 DC A(XALDSNAM) Data set name
X99TU2 DC A(XALSTATS) Data set status, new
X99TU3 DC A(XALNDISP) Normal disposition
X99TU4 DC A(XALCDISP) Conditional disposition
X99TULAS EQU *
X99TU5 DC A(XALDDNAM) DDNAME
*
XALDSNAM DS 0F Data set name specification
DC AL2(DALDSNAM) Data set name to be allocated
DC AL2(1) Must be a 1
XDSNAMEL DC AL2(44) Data set name length
XDSNAME DC CL44' ' Data set name
*
XALSTATS DS 0F Data set status
DC AL2(DALSTATS)
DC AL2(1) Must be a 1
DC AL2(1) Length is 1
DC AL1(WSHR) Disposition
*
XALNDISP DS 0F Data set normal disposition
DC AL2(DALNDISP)
DC AL2(1)
DC AL2(1) Length is 1
DC AL1(WKEEP)
*
XALCDISP DS 0F Data set conditional disposition
DC AL2(DALCDISP)
DC AL2(1)
DC AL2(1)
DC AL1(WKEEP)
*
XALDDNAM DS 0F DDNAME
DC AL2(DALDDNAM)
DC AL2(1)
DC AL2(6)
DC CL6' '
*
XRESERVE DC C'JCLOUT'
DC CL2' '
LXRESERV EQU *-XRESERVE
*
XD9RBPTR DC A(XC9RB) Deallocation parameter list
XD9RB DC AL1(20)
XD9VERB DC AL1(S99VRBUN)
XD9FLAG1 DC AL2(0)
XD9ERROR DC AL2(0)
XD9INFO DC AL2(0)
XD9TXTPP DC AL4(0)
DC AL4(0)
XD9FLAG2 DC AL4(0)
SC9TUPTR DS 0F
XD9TULAS EQU *
XD9TU1 DC A(XDLDDNAM)
XDLDDNAM DS 0F
DC AL2(DUNDDNAM)
DC AL1(1)
DC AL2(6)
DC C'JCLOUT'
DC CL2' '
*
XSWAREQ SWAREQ FCODE=RL,EPA=XEPAADDR,MF=L
XSYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=PM,BLKSIZE=80, X
LRECL=80
XJCLOUT DCB DDNAME=JCLOUT,DSORG=PO,MACRF=W
XJCLIN DCB DDNAME=JCLIN,DSORG=PS,MACRF=GL,EODAD=EOJCLIN
XJCLINL EQU *-XJCLIN
*
XARMMSG WTO 'DBR7JCLR: PROGRAM PARM ERROR IN POSITION XXXX',X
MF=L
XMSGERR1 WTO 'DBR00015: INPUT IMAGEXXXX INSUFFICIENT COLUMNS X
TO EXPAND',MF=L
XMSGERR2 WTO 'DBR00016: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX',MF=L Input image where err occurred
*
XXCAREA XC 0(*-*,R1),0(R1)
XLCINS CLC 0(*-*,R2),INSLIT-INSDSECT(R3)
XVCJCL MVC JCLIMAGE-JCLDSECT(*-*,R1),0(R3)
XVCLEAD MVC 0(*-*,R3),JCLIMAGE-JCLDSECT(R1)
XVCDSN MVC 0(*-*,R3),WDSNM
XVCTRAIL MVC 0(*-*,R3),0(R2)
XMVCJOB MVC 0(*-*,R3),0(R14)
*
DC CL8'XAREAEND'
XAREAEND EQU *
XAREAENL EQU *-XAREABGN
EJECT
*
* This routine process keyword %DSN% in the JCL mask
* The actual data set name will be substituted in the
* location where the keyword string is
*
RTN1 CSECT ,
STM R0,R15,RTNSAVE
XC RTNSAVE+(15*4)(4),RTNSAVE+(15*4) Expect RC=0
LR R12,R15
USING RTN1,R12 Setup a new base register
*
LR R4,R2 Addr char 1 of insert string
LA R3,JCLIMAGE Address JCL image char 1
LH R14,WAVLRECL Input logical record length
S R14,=A(MAXSEQ+1) Minus columns 72-80
STH R14,WRKLRECL Max # columns that have data
LA R14,0(R3,R14) Scan backwards truncating
BCTR R14,R0 trailing blanks
BCTR R14,R0
LH R15,WRKLRECL
RTN1A DS 0H
CLI O(R14),C' '
BNE RTN1B
BCTR R14,R0 Backup past trailing blank
BCT R15,RTN1A Keep going to we hit data
RTN1B DS 0H
SR R14,R3 # chars to last data char
SR R14,R9 Length of insert string - 1
SR R4,R3 Len of preceding JCL characters
SR R14,R4
ST R14,JCLEN
LH R14,WRKLRECL Do we have room to move leading
SR R14,R4
LTR R14,R14
BNM RTN1C Yes we do
L R15,=V(RTNERR1) No we do not, it is an error
BALR R14,R15
LA R15,CODE8 Return to caller with retcode
ST R15,RTNSAVE+(15*4)
B RTN1X Exit
RTN1C DS 0H
STH R14,WRKLRECL Save number of chars left
BCTR R4,R0
L R3,WJCLWORK
LR R14,R3
LH R15,WAVLRECL
RTN1D DS 0H
MVI 0(R14),C' '
LA R14,1(,R14)
BCT R15,RTN1D
EX R4,WMVCLEAD Move chars before the keyword
LA R3,1(R4,R3) Next work area address
SR R4,R4
IC R4,WDSNML Data set name length
LH R14,WRKLRECL Got room for dsname in output
SR R14,R4
LTR R14,R14
BNM RTN1E Yes we do
L R15,=V(RTNERR1) No room is an error
BALR R14,R15
LA R15,CODE8
ST R15,RTNSAVE+(15*4) Set nonzero RC in save area
B RTN1X
RTN1E DS 0H
STH R14,WRKLRECL Save number of chars left
BCTR R4,R0 Move data set name where the
EX R4,WMVCDSN keyword was in the JCL image
LA R3,1(R4,R3) next work address
LA R2,1(R9,R2) Char 1 after data set name
L R4,JCLEN Count keyword to last nonblank
LH R14,WRKLRECL Is there room to move chars
SR R14,R4 after the keyword
STH R14,WRKLRECL
SR R14,R4
STH R14,WRKLRECL
LTR R14,R14
BNM RTN1F Yes there is room for remainder
L R14,=V(RTNERR1)
BALR R14,R15 No room at the Inn, display err
LA R15,CODE8 Return to caller with RC=8
ST R15,RTNSAVE+(15*4)
RTN1F DS 0H
BCTR R4,R0
EX R4,WMVCTRL Move chars after keyword
LA R2,JCLIMAGE GETMAIN where JCL was stored
LH R14,WAVLRECL Logical record length
LA R2,0(R14,42) Last input char + 1
S R2,=A(MAXSEQ+1) Backup to move-from column 72
L R3,WJCLWORK
LH R14,WAVLRECL
LA R3,0(R14,R3) Move the sequence number and
S R3,=A(MAXSEQ+1) continuation character if there
LA R4,MAXSEQ is one. Even if there is none
EX R4,WMVCTRL we will move the blanks in cols
L R3,WJCLWORK 72-80
LH R4,WAVLRECL After the JCL statement
BCTR R4,R0 has data set name
EX R4,WMVCJCL move it back to the ctlblk
*
RTN1X DS 0H Restore the caller's registers
LM R0,R15,RTNSAVE w/return code in reg 15
BR R14 and, return to the caller
DROP R12
EJECT
*
* This routine processes %SERIAL% in the JCL mask.
* The unload DASD volume serial number will be
* substituted where %SERIAL% appears in the JCL mask
*
RTN2 CSECT ,
STM R0,R15,RTNSAVE Save caller's regs
LR R12,R15 Setup a new base register
USING RTN2,R12
XC RTNSAVE+(15*4)(4),RTNSAVE+(15*4) Assume good
MVI WCAMDSN,C' ' return code
MVC WCAMDSN+1(L'WCAMDSN-1),WCAMDSN Clear dsname
LA R3,WCAMDSN in the CAMLST
LA R4,WDSNM
SR R14,R14
IC R14,WDSNML
RTN2A DS 0H
MVC 0(1,R3),0(R4) Move data set name to
LA R3,1(,R3) CAMLST
LA R4,1(,R4)
BCT R14,RTN2A
*
LOCATE WCAMLST Issue CAMLST macro
L R1,RTNSAVE+(1*4)
RTN2B DS 0H
LH WCAMAREA Do we have a volume count
LTR R15,R15
BNZ RTN2C Yes.
SLL R15,8 No. shift R15 contents 8 bits
IC R15,CODE16 R15 = 00000010
ST R15,RTNSAVE+(15*4)
B RTN2X
*
RTN2C DS 0H
LR R4,R2 Addr char 1 of insert string
LA R3,JCLIMAGE Addr char 1 of JCL mask
LH R14,WAVLRECL Input logical record length
S R14,=A(MAXSEQ+1) Minus columns 72-80
STH R14,WRKLRECL Is the # of data columns
LA R14,0(R3,R14) A(sequence # 1) in col 73
BCTR R14,R0 Backup to col 72
BCTR R14,R0 Backup to col 71
LH WRKLRECL Max number of columns for data
*
RTN2D DS 0H
CLI 0(R14),C' ' Truncate trailing blanks
BNE RTN2E It is not a blank
BCTR R14,R0 It is a blank, backup past it
BCT R15,RTN2D Keep truncating blanks
RTN2E DS 0H
SR R14,R3 1st nonblank char at the end
SR R14,R9 length of insert string - 1
ST R14,JCLEN Len to last nonblank char
*
RTN2F DS 0H
STH R14,WRKLRECL Save number of chars left
BCTR R4,R0
L R3,WJCLWORK
LR R14,R3
LH R15,WAVLRECL
RTN2G DS 0H
MVI 0(R14),C' '
LA R14,1(,R14)
BCT R15,RTN2G Clear receiving area to blanks
EX R4,WMVCLEAD Move leading chars up to first
LA R3,1(,R4,R3) Addr where to put next char
SR R14,R14
LH R15,WCAMAREA Get output volume serial count
M R14,=A(MAXSER) times len of 1 volume serial
AH R15,WCAMAREA + volume serial count + 1
BCTR R15,R0 - 1 = # volser bytes
LR R4,R15 + delimiter bytes
*
LH R14,WRKLRECL Room to move the volser
SR R14,R4
LTR R14,R14
BNM RTN2H Yes
L R15,=V(RTNERR1) No room no room
BALR R14,R15 Go to error routine
LA R15,CODE8
ST R15,RTNSAVE+(15*4)
B RTN2X Return to caller rc=8
RTN2H DS 0H
STH R14,WRKLRECL Save number of chars left
LH R15,WCAMAREA Volume serial number count
LA R5,WCAMAREA+2 Addr(volume serials)
USING LOCDSECT,R5 LOCATE volume list
*
RTN2J DS 0H
MVC 0(L'LVOLSER,R3),LVOLSER Move one serial number
LA R3,L'LVOLSER(,R3) Char 1 after that volser
LA R5,LLOCDSEC(,R5)
BCTR R15,R0 -1 from volser total
LTR R15,R15 More volsers to move?
BZ RTN2K No. we moved them all
MVI 0(R3),C' ' Put blank after volser
LA R3,1(,R3) Next move-to address
B RTN2J Move next output volser
RTN2K DS 0H Moved all the volsers
L R1,RTNSAVE+(4*1) Restore original reg 1
LA R2,1(R9,R2) Char 1 after keyword
L R4,JCLEN Last nonblank char+1
LH R14,WRKLRECL Do we have room to move
SR R14,R4 the characters after the
STH R14,WRKLRECL keyword string
LTR R14,R14
BNM RTN2L We have room
L R15,=V(RTNERR1)
BALR R14,R15 No room is an error
LA R15,CODE8 so return to caller with
ST R15,RTNSAVE+(15*4) return code 8 in reg 15
B RTN2X
*
RTN2L DS 0H
EX R4,WMVCTRL Move chars after keyword
LA R2,JCLIMAGE Work area address
LH R14,WAVLRECL Logical record length
LA R2,0(R14,R2) Addr last input char + 1
S R2,=A(MAXSEQ+1) Subtract cols 72-80
LA R4,MAXSEQ Max # sequence can be
EX R4,WMVCTRL cols 72-80 to output
L R3,WJCLWORK
LH R4,WAVLRECL Now, move completed JCL
BCTR R4,R0 statement to the control
EX R4,WMVCJCL where the JCL mask state
*
RTN2X DS 0H And return to sender ...
LM R0,R15,RTNSAVE Address is known
BR R14 We did it
EJECT
*
* This routine substitutes an actual jobname where
* %JOB% appears in the JCL mask. It is basically like
* RTN1 and RTN2, i.e., move the characters before %JOB%,
* substitute the jobname where %JOB% is in the JCL mask,
* move continuation column 72 and sequence columns 73-80,
* move the trailing characters after keyword %JOB%.
*
RTN3 CSECT ,
STM R0,R15,RTNSAVE
LR R12,R15
USING RTN3,R12
XC RTNSAVE+(15*4),RTNSAVE+(15*4)
LA R3,WTIOT TIOT address
LA R4,WEXTRACT
EXTRACT ((R3)),,,MF=(E,(4))
L R1,RTNSAVE+(1*4) Restore reg 1
LR R4,R2 Address keyword char 1
LA R3,JCLIMAGE Address JCL mask char 1
LH R14,WAVLRECL JCL mask input rec len
S R14,=A(MAXSEQ+1) # continue cols + seq
STH R14,WRKLRECL only want the data columns
AR R14,R3 Addr continuation column 72
BCTR R14,R0 Addr last data char
LH R15,WRKLRECL Max number of data columns
RTN3D DS 0H
CLI O(R14),C' ' Strip off the trailing blan
BNE RTN3E No more to strip
BCTR R14,R0 Backup 1 past blank
BCT R15,RTN3D Keep going
RTN3E DS 0H
SR R14,R3 # chars to last nonblank mi
SR R14,R9 Insert string length - 1
ST R14,JCLEN # chars to last nonblank -
RTN3F DS 0H
STH R14,WRKLRECL Save # input chars left
BCTR R14,R0 -1
L R3,WJCLWORK
LR R14,R3
LH R15,WAVLRECL
RTN3G DS 0H
MVI O(R14),C' '
LA R14,1(,R14)
BCT R15,RTN3G
EX R4,WMVCLEAD Move leading chars from JCL
LA R3,1(R4,R3) Next free addr in work area
L R14,WTIOT TIOT address
USING TIOT1,R14 Char 2 shipment letter
LA R14,TIOCNJOB+1 Char 3-8 is unloaded
DROP R14 DASD volume serial number
LA R15,L'TIOCNJOB-1 Get jobname length - 1
SR R4,R4 Clear number chars to move
RTN3H DS 0H
CLI 0(R14),C' ' Find blank after jobname
BE RTN3I in case jobname < 8
LA R4,1(,R4) chars
LA R14,1(,R14)
BCT R15,RTN3H
RTN3I DS 0H
LH R14,WRKLRECL Do we have room to replace
SR R14,R4 %JOB% with actual jobname
LTR R14,R14
BNM RTN3J Yes.
L R15,=V(RTNERR1) No. display error msg
LA R15,CODE8 Set return code equal 8
ST R15,RTNSAVE+(15*4)
B RTN3X
RTN3J DS 0H
STH W14,WRKLRECL Save # chars left in input
L R14,WTIOT
USING TIOT1,R14
LA R14,TIOCNJOB+1-TIOT2(,R14) Addr jobname+1
MVC DASDSER,1(R14) DASD volser to work area
MVC WDSNSUF,0(R14) Move shipment character
DROP R14
BCTR R4,R0 -1 for EXEC MVC
XC PDSENT(LPDSENT),PDSENT
LR R6,R3
MVC 0(L'JOB1CHAR,R3),JOB1CHAR
LA R3,L'JOB1CHAR(,R3) Move char 1 of jobname
EX R4,WMVCJOB Shipment char ID unload
MVC PDSNAME,0(R6) DASD volser to restore
RTN3K DS 0H JOB jobname
BCTR R4,R0
EX R4,WMVCTRL Move trailing chars after
L R3,WJCLWORK %JOB%
LH R14,WAVLRECL
LA R3,0(R14,R3)
S R3,=A(MAXSEQ+1)
LA R2,JCLIMAGE
LH R14,WAVLRECL
LA R2,0(R14,R2)
S R2,=A(MAXSEQ+1)
LA R4,MAXSEQ
EX R4,WMVCTRL Move cols 72-80 from mask
LA R3,JCLIMAGE to output
L R2,WJCLWORK
LH R4,WAVLRECL Move the completed JCL card
BCTR R4,R0 the JCL input mask
EX R4,WMVCTRL
RTN3X DS 0H
LM R0,R15,RTNSAVE Restore regs w/retcode
BR R14 Return to caller
*
LTORG
DROP R12
EJECT
* This routine processes keyword %VOL% in JCL mask
*
RTN4 CSECT ,
STM R0,R15,RTNSAVE
LR R12,R15
USING RTN4,R12
XC RTNSAVE+(15*4)(4),RTNSAVE+(15*4)
*
LR R4,R2
LA R3,JCLIMAGE
MVC WJCLAREA,0(R3)
LH R14,WAVLRECL
S R14,=A(MAXSEQ+1) Max data columns is 71
STH R14,WRKLRECL
AR R14,R3
BCTR R14,R0 R14 -> last possible
LH R15,WRKLRECL column is column 71
RTN4D DS 0H
CLI 0(R14),C' ' Backup past trailing blanks
BNE RTN4E
BCTR R14,R0
BCT R14,RTN4D
RTN4E DS 0H
SR R14,R3 # columns to 1st trailing
SR R14,R9 blank
ST R14,JCLEN Calculate # chars after
SR R4,R3 %VOL%
L R14,JCLEN
SR R14,R4
ST R14,JCLEN
LH R14,WRKLRECL Room for chars up to %VOL%
SR R14,R4
LTR R14,R14
BNM RTN4F Yes.
L R15,=V(RTNERR1) No. it is an error
BALR R14,R15
LA R15,CODE8
ST R15,RTNSAVE+(15*4)
B RTN4X
RTN4F DS 0H
STH R14,WRKLRECL
BCTR R4,R0
L R3,WJCLWORK
LR R14,R3
LH R14,WAVLRECL
RTN4G DS 0H
MVI 0(R14),C' '
LA R14,1(,R14)
BCT R15,RTN4G Chars before %VOL%
EX R4,WMVCLEAD but not %VOL%
LA R3,1(R4,R3)
MVC 0(L'DASDSER,R3),DASDSER Move unload volser over
LA R3,1(R4,R3) %VOL% in JCL mask
LR R2,1(R9,R2)
L R4,JCLEN
LH R14,WRKLRECL
SR R14,R4
STH R14,WRKLRECL Have room for chars
LTR R14,R14 after %VOL% in JCL mask
BNM RTN4K Yes.
L R15,=V(RTNERR1) No. display error msg
BALR R14,R15
LA R15,CODE8
ST R15,RTNSAVE+(15*4) and return to caller
B RTN4X
RTN4K DS 0H Here to move remaining char
EX R4,WMVCTRL
L R3,WJCLWORK
LH R14,WAVLRECL
LA R3,0(R14,R3)
S RE,=A(MAXSEQ+1)
LA R2,JCLIMAGE
LH R14,WAVLRECL
LA R2,0(R14,R2)
S R2,=A(MAXSEQ+1)
LA R4,MAXSEQ
EX R4,WMVCTRL Move columns 72 to 80
LA R3,JCLIMAGE
L R2,WJCLWORK
LH R4,WMVCLRECL
BCTR R4,R0 Move completed JCL image
EX R4,WMVCTRL where the JCL mask is
RTN4X DS 0H
LM R0,R15,RTNSAVE
BR R14 Return to caller
LTORG
DROP R12
EJECT
*
* This routine is entered when there are move characters
* in the JCL mask, but the output area is not big enough
* for them. Reg 1 contains the address of the JCL
* mask control block at entry.
*
RTNERR1 CSECT ,
STM R0,R15,RTNER1SA Save caller's registers
LR R12,R15
USING RTNERR1,R12
USING JCLDSECT,R1
MVC WMSGERR2+13(80),JCLIMAGE JCL mask to err msg
L R14,JCLSEQ
CVD R15,WDOUBLE input mask number
MVC WMSGERR1+25(4),=X'40202120' edit mask to msg
ED WMSGERR1+25(4),WDOUBLE+6
LA R1,WMSGERR1
WTO MF=(E,(1))
LM R0,R15,RTNER1SA Display error message
BR R14
*
LTORG
DROP R1
DROP R12
EJECT
*
* This is the program work area obtained with GETMAIN
* The following areas are not initialized from program
* constants
*
WAREABGN DSECT 0D
WSAVE DS 18F Saved registers at entry
RTNSAVE DS 16F RTN1-RTN4 saves caller regs here
RTNER1SA DS 16F RTNERR1 saves caller regs here
WDOUBLE DC D'0' Primarily used to convert numeric
WSAVJFCB DS A Addr Job File Control Block
WJCL DS A Addr 1st JCL mask control block
WJCL1 DS A Addr 1st JCL mask ctl.blk. copy 2
WJCLWORK DS A A(JCL statement) work area
WRKSEQ DS F JCL mask chain ctl.blk. sequence #
WAVLRECL DS AL2 JCL input LRECL, constant number
WRKLRECL DS AL2 JCL input LRECL counter (changes)
WDSNML DS AL1 Len dsname no trailing blanks
WDSNSUF DS C Put shipment ID here, A-Z
DASDSER DS CL6 Unloaded DASD volume serial number
JOB1CHAR DS C First character of job name
JOB1UNLD EQU Y Default char 1 for unload jobs
JOB1REST EQU Z Default char 1 for restore jobs
WDSNM DS CL44 Data set name work area
*
PDSENT DS 0F
PDSNAME DS CL8 Partitioned data set member name
PDSTTR DS XL3 System updates for add or replace
PDSC DS XL1 Entry type
LPDSENT EQU *-PDSENT Length of a PDSENT entry
*
WFLAG DC X'00' Program flag
WFLAG1ST EQU B'10000000' On, we are processing output copy 1
*
WEND DC CL8'WAREAEND' End of uninit GETMAIN area
*
* The following areas are initialized by moving the
* fields to this part of the GETMAIN area
*
DS 0D
WXBGN DC CL8'XAREABGN'
WEPAADDR DC A(WEPAAREA) SWAREQ macro parameter address
WEPAAREA DC 4F'0' SWAREQ macro parameters
*
CAMDSN EQU 4
CAMAREA EQU 12
WCAMAREA DS 0D
DS CL265
WCAMDSN DS CL44 Unload data set name for LOCATE
WCAMLST CAMLST NAME,WCAMDSN,,WCAMAREA
*
WTIOT DS F This job's TIOT address
WEXTRACT EXTRACT WTIOT,'S',FIELDS=TIOT,MF=L
*
W99BGN EQU * SVC 99 dynamic allocate workarea
W99RBPTR DC A(W99RB)
*
W99RB DS 0F
W99RBLN DC AL1(20)
W99VERB DC AL1(S99VRBAL)
W99FLAG1 DC AL2(0)
W99ERROR DC AL2(0)
W99INFO DC AL2(0(
W99TXTPP DC AL4(0)
DC AL4(0)
W99FLAG2 DC AL4(0)
*
W99TUPTR DS 0F SVC 99 text unit addresses
W99TU1 DC A(WALDSNAM) Data set name
W99TU2 DC A(WALSTATS) Data set status, e.g., new
W99TU3 DC A(WALNDISP) Data set normal disposition
W99TU4 DC A(WALCDISP) Data set conditional disposition
W99TULAS EQU * Last text unit pointer follows
W99TU5 DC A(WALDDNAM) DDNAME as in a JCL statement
*
WALDSNAM DS 0F Data set name specification
DC AL2(DALDSNAM) Name of data set to be allocated
DC AL2(1) Must be a 1
WDSNAMEL DC AL2(0) Dataset name length
WDSNAME DC CL44' '
*
WALSTATS DS 0F Data set status, e.g., SHR
DC AL2(DALSTATS)
DC AL2(1)
DC AL2(1) Length is always 1
DC AL1(WSHR) This data set status is SHR
WSHR EQU X'00'
*
WALNDISP DS 0F Data set normal disposition
DC AL2(DALNDISP)
DC AL2(1)
DC AL2(1)
DC AL1(WKEEP)
WKEEP EQU X'08'
*
WALCDISP DS 0F Data set conditional disposition
DC AL2(DALCDISP) KEEP
DC AL2(1)
DC AL2(1)
DC AL1(WKEEP)
*
WALDDNAM DS 0F DDNAME as in a JCL statement
DC AL2(DALDDNAM)
DC AL2(1)
DC AL2(6)
*
W99END EQU *
*
WRESERVE DC C'JCLOUT' Allocate and RESERVE DDNAME
DC CL2' '
LWRESERV EQU *-WRESERVE
*
WD9RBPTR DC A(WD9RB) Deallocate parameter list
WD9RB DS 0F
WD9RBLN DC AL1(20)
WD9VERB DC AL1(S99VRBUN)
WD9FLAG1 DC AL2(0)
WD9ERROR DC AL2(0)
WD9INFO DC AL2(0)
WD9TXTPP DC AL4(0)
DC AL4(0)
WD9FLAG2 DC AL4(0)
WD9TUPTR DS 0F
WD9TULAS EQU *
WD9TU1 DC A(WDLDDNAM) DDNAME for deallocate
WDLDDNAM DS 0F
DC AL2(DUNDDNAM)
DC AL1(1)
DC AL2(6)
DC C'JCLOUT'
DC CL2' '
*
WSWAREQ SWAREQ FCODE=RL,EPA=WEPAADDR,JF=L
*
WSYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=PM,BLKSIZE=80, X
LRECL=80
*
WJCLOUT DCB DDNAME=JCLOUT,DSORG=PO,MACRF=W
*
WJCLIN DCB DDNAME=JCLIN,DSORG=PS,MACRO=GL,EODAD=EOJCLIN
*
WPARMMSG WTO 'DBR7JCLR: PROGRAM PARM ERROR IN POSITION XXXX',C
MV=L
*
WMSGERR1 WTO 'DBR00015: INPUT IMAGEXXXX INSUFFICIENT COLUMNS X
TO EXPAND',MF=L
WMSGERR2 WTO 'DBR00016: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX',MF=L Input image where err occurred
*
WCAREA XC 0(*-*,R1),0(R1)
WCLCINS CLC 0(*-*,R2),INSLIT-INSDSECT(R3)
WMVCJCL MVC JCLIMAGE-JCLDSECT(*-*,R1),0(R3)
WMVCLEAD MVC 0(*-*,R3),JCLIMAGE-JCLDSECT(R1)
WMVCTRL MVC 0(*-*,R3),0(R2)
WMVCJOB MVC 0(*-*,R3),0(R14)
*
DC CL8'XAREAEND' End of initialized GETMAIN area
WXEND EQU *
WAREAEND EQU *
*
* Dummy Sections follow
*
JCLDSECT DSECT ,
JCLPREV DS A Addr previous JCL mask image
JCLNEXT DS A Addr next JCL mask image or 0
JCLSEQ DS F JCL mask sequence number
JCLEN DS F Length JCL mask +1
JCLIMAGE EQU * Begin JCL mask image
*
INSDSECT DSECT ,
INSWTG DS A where-to-go
INSLEN DS AL1 Keyword length
INSLIT DS CL11 Max key 11 chars
LINSENT EQU *-INSDSECT
*
LOCDSECT DSECT ,
LDEVTYPE DS CL4 Device code
LVOLSER DS CL6 Volume serial number
LSEQ DS CL2 Volume sequence number
LLOCDSEC EQU *-LOCDSECT
*
DBRENT DSECT 0F
DBRLEN DS AL1 Actual keyword length
DBRFLAG DS AL1 Flag byte
DBRIN EQU B'10000000' This keyword found
DBRNREQ EQU B'01000000' This keyword is not required
DS AL2
DBRWTG DS A Addr routine
DBRCON DS CL12 Entry parameter
DBRENTL EQU *-DBRLEN Entry length
*
*
* Operating System DSECTs follow
*
PRINT NOGEN
IEFZB505
LZB505 EQU *-ZB505
*
IEFJESCT
*
IKJTCB
*
IEZJSCB
*
IEFAJCTB
*
IEFASCTB
*
IEFASIOT
*
IEFTIOT1
*
IEFJFCBN
*
IEFUCBOB PREFIX=YES
*
IHAPSA
*
CVT DSECT=YES
*
IEFZB4D0
*
IEFZB4D2
*
DCBD DSORG=PS
*
END