i am unable to post my entire code in one post. So splitting it into 2 posts.
Please look at my code suggest the changes.
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
MVSGPSVC TITLE 'MVS/XA GENERAL PURPOSE SVC - IGC0025B ' 00010011
* PRINT OFF,NOGEN 00020000
MACRO 00030000
PROLOG 00040000
*---------------------------------------------------------------------- 00050000
* * 00060000
* NAME.......... MVSGPSVC (MVS GENERAL PURPOSE SVC) * 00070000
* * 00080000
* FUNCTION...... MULTIFUCTION TYPE-3 USER SVC * 00090000
* (SEE DESCRIPTION BELOW) * 00100000
* * 00110000
* ATTRIBUTES.... REENTRANT REUSEABLE * 00120000
* * 00130000
* MODE:......... RMODE=24 AMODE=31 (MVS/XA COMPATIBLE) * 00140009
* * 00150000
* DEPENDENCIES.. "IOSVSUCB" UCB SCAN SERVICE ROUTINE OF * 00160000
* EITHER MVS SP1.3 OR SP2.1 (AND HIGHER) * 00170000
* THIS DEPENDENCY MAY BE ELIMINATED FOR * 00180000
* SYSTEMS PRIOR TO SP1.3 BY DROPPING THE * 00190000
* UCB SCAN ROUTINE IF NOT NEEDED. * 00200000
* * 00210000
*---------------------------------------------------------------------- 00220000
SPACE 1 00230000
*********************************************************************** 00240000
* * 00250000
* DESCRIPTION: * 00260000
* PERFORM SEVERAL FUNCTIONS AS AN SVC WHICH ARE * 00270000
* CONTROLLED BY ENTRY POINT INDICATOR PASSED IN * 00280000
* R15. THE TYPE OF FUNCTIONS CONTAINED HEREIN * 00290000
* ARE THOSE PECULIAR TO EITHER THE MACHINE OR THE * 00300000
* OPERATING SYSTEM WHICH HAVE A POSSIBILITY OF * 00310000
* FOR CHANGE. BY INCLUDING THSES TYPE OF FUNCTIONS * 00320000
* IN A CENTRAL PLACE (HERE), WHEN CHANGES ARE REQUIRED * 00330000
* THEY MAY BE GLOBALLY CHANGED VIA A SINGLE CHANGE * 00340000
* (HERE). * 00350000
* * 00360000
* ENTRY CODES ARE AS FOLLOWS: * 00370000
* R15=1 - USER SVC TEST VIA LOAD AND BRANCH * 00380000
* R15=2 - DATE, DAY OF WEEK, TIME * 00390000
* R15=3 - SET APF AUTHORIZATION * 00400000
* R15=4 - RESET APF AUTHORIZATION * 00410000
* R15=5 - SMFWTM * 00420000
* R15=6 - UCB LOOKUP (MVS/XA COMPATIBLE) * 00430000
* R15=7 - JCT LOOKUP (CURRENT ASID ONLY), TSUID INFO * 00440000
* R15=8 - JES JOBID ADDRESS * 00450000
* R15=9 - JES INPUT DEVICE ADDRESS * 00460000
* R15=10 - FULL SCREEN TPUT CLEAR * 00470000
* R15=11 - CALENDAR TO JULIAN DATE CONVERT (FWW) * 00480000
* R15=12 - JULIAN TO CALENDAR DATE CONVERT (FWW) * 00490000
* R15=13 - JULIAN DATE DIFFERENCE CALCULATION (FWW) * 00500000
* R15=14 - UNUSED AT THIS TIME (A B) * 00510000
* R15=15 - UNUSED AT THIS TIME (TEMP USE FOR RACF) * 00520000
* R15=16 - UNUSED AT THIS TIME (OPEN) * 00530000
* R15=17 - UNUSED AT THIS TIME (OPEN) * 00540000
* R15=18 - UNUSED AT THIS TIME (OPEN) * 00550000
* R15=19 - UNUSED AT THIS TIME (OPEN) * 00560000
* * 00570000
* NOTE. * 00580000
* BECAUSE WE ARE AN SVC, THERE IS NO NEED TO SAVE * 00590000
* THE USERS REGISTER (THE SYSTEM HAS ALREADY SAVED * 00600000
* THEM). ALSO, CERTAIN REGISTERS HAVE BEEN PRIMED * 00610000
* FOR US AS FOLLOWS: * 00620000
* * 00630000
* R0 = SAME AS WHEN SVC WAS ISSUED (AT ENTRY TO EXIT) * 00640000
* R1 = SAME AS WHEN SVC WAS ISSUED (AT ENTRY TO EXIT) * 00650000
* R2 = UNPREDICTABLE * 00660000
* R3 = CVT ADDRESS * 00670000
* R4 = TCB ADDRESS(CURRENT) * 00680000
* R5 = SVRB ADDRESS (OURS) * 00690000
* R6 = ENTRY POINT (OUR BASE REG) * 00700000
* R7 = ASCB ADDRESS (CURRENT) * 00710000
* R8 = UNPREDICTABLE * 00720000
* R9 = UNPREDICTABLE * 00730000
* R10 = UNPREDICTABLE * 00740000
* R11 = UNPREDICTABLE * 00750000
* R12 = UNPREDICTABLE * 00760000
* R13 = SAME AS WHEN SVC WAS ISSUED (AT ENTRY TO EXIT) * 00770000
* R14 = RETURN REGISTER (TO SVC RETURN HANDLER) * 00780000
* R15 = SAME AS WHEN SVC WAS ISSUED (AT ENTRY TO EXIT) * 00790000
* * 00800000
* THIS ROUTINE IS LINKEDITED AS AN SVC (TYPE 3) TO * 00810000
* BE INCLUDED VIA 'MLPA' AT IPL TIME. BECAUSE THIS * 00820000
* IS AN SVC, IT MUST REMAIN RE-ENTERABLE. * 00830000
* * 00840000
*********************************************************************** 00850000
MEND 00860000
MACRO 00870000
JCTGET 00880001
.* 00890001
.* FIND OUR JCT (RELEASE DEPENDENT) DKM 00900001
.* 00910000
GBLA &I 00920000
&I SETA &SYSNDX 00930000
.* 00940000
USING JESCT,R2 00950002
USING SSCT,R5 00960002
USING SSVT,R8 00970002
USING SJB,R11 00980005
SPACE 1 00990002
LA R15,16 ASSUME BADNESS, RC=16 01000000
L R2,CVTJESCT ADDR OF JESCT FROM CVT 01010000
CLC JESCTID,=CL4'JEST' VALIDATE CONTROL BLOCK 01020000
BNER R14 INVALID, ERROR RETURN 01030000
SPACE 1 01040000
ICM R5,15,JESSSCT ADDR OF SSCT (1ST SSCT FROM JESCT) 01050000
JCT@&I DS 0H 01060000
BZR R14 INVALID ERROR RETURN, RC=16 01070000
SPACE 1 01080000
CLC SSCTID,=CL4'SSCT' VALIDATE CONTROL BLOCK 01090000
BNER R14 INVALID, ERROR RETURN, RC=16 01100000
CLC SSCTSNAM,=CL4'JES2' CHECK FOR MATCHING SUBSYSTEM NAME 01110000
BE JCT#&I YES, CONTINUE 01120000
SPACE 1 01130000
ICM R5,15,SSCTSCTA GET NEXT SUBSYSTEM SSCT 01140000
B JCT@&I CHECK NEXT 01150000
SPACE 3 01160000
JCT#&I DS 0H 01170000
ICM R8,15,SSCTSUS2 ADDRESS OF SSVT FROM SSCT 01180000
BZR R14 INVALID ERROR RETURN, RC=16 01190000
USING HCCT,R8 01200000
SPACE 1 01210000
LA R15,4 LIGHTEN UP A BIT ... 01220000
ICM R9,15,CCTHASP CHECK IF HASP IS STILL UP 01230000
BNZR R4 RETURN CODE = 4, EXIT 01240000
ICM R9,15,CCTHAVT ADDRESS OF JES2 HAVT 01250000
BNPR R4 NOT THERE, HASP NOT UP, RC=4 01260000
USING PSA,R0 PSA ADDRESS 01270002
L R7,PSAAOLD ADDRESS OF CURRENT ASCB 01280000
LH R15,ASCBASID GET ASID FROM ASCB 01290000
SLL R15,2 MULTIPLY BY 4 01300000
AR R9,R15 ADDRESS OF OUR HAVT ENTRY 01310000
SPACE 1 01320000
* ------------------------------------------------------------------- * 01330000
* CHAIN TO THE SJB VIA THE HASB * 01340000
* ------------------------------------------------------------------- * 01350000
ICM R11,15,0(R9) ADDRESS OF HASB FROM JES2 HAVT 01360000
BNPR R4 NOT THERE, SPECIAL SYSTEM TASK 01370000
USING HASB,R11 ESTABLISH ADDRESSABILITY 01380000
CLC HSBID,=C'HASB' VALIDATE HASB 01390000
BNER R4 INVALID, RETURN 01400000
ICM R11,15,HSBSJB ADDRESS OF SJB FROM HASB 01410000
DROP R11 DROP USING ON HSB 01420000
BNPR R4 NOT THERE, SPECIAL SYSTEM TASK 01430000
USING SJB,R11 ESTABLISH ADDRESSABILITY 01440000
SPACE 1 01450000
CLC SJBID,=CL4'SJB' VALIDATE SJB CONTROL BLOCK 01460000
BNER R14 INVALID, RETURN 01470000
SPACE 1 01480000
ICM R15,15,SJBSJB ADDRESS OF DEPENDENT SJB 01490000
BZ JCTNB&I NONE, NOT BATCH 01500000
LR R11,R15 INITIATOR'S DEPENDENT SJB 01510000
SPACE 1 01520000
JCTNB&I DS 0H 01530000
L R10,SJBJCT JOBS JCT 01540000
LA R15,16 ONE MORE VALIDATION ... 01550000
CLC JCTID,=CL4'JCT ' VALID JCT?? 01560000
BNER R14 NO? OUTTA HERE... 01570000
SR R15,R15 SET HAPPY CAMPER MODE 01580000
MEND 01590000
EJECT 01600000
*********************************************************************** 01610000
* * 01620000
* INITIAL ENTRY POINT (DRIVER FOR SUBROUTINES). * 01630000
* THIS ROUTINE CHECKS FOR A VALID ENTRY POINT INDICATOR * 01640000
* PASSED IN R15. IF IT IS VALID, R6 IS SET TO THE * 01650000
* APPROPRIATE ENTRY POINT ADDRESS AND CONTROL IS PASSED * 01660000
* TO TO THE ROUTINE. IF IT IS INVALID, IT MERELY RETURNS * 01670000
* TO THE CALLER VIA R14. * 01680000
* * 01690000
* DATA AREAS REQUIRED BY A SINGLE ROUTINE SHOULD BE INCLUDED * 01700000
* AT THE END OF THAT ROUTINE (FOR ADDRESSABILIY REASONS). * 01710000
* THOSE THAT ARE USED BY MULTIPLE ROUTINES SHOULD BE INCLUDED * 01720000
* AT THE END OF THE LAST ROUTINE TO USE IT (OR AT THE END * 01730000
* OF THE CODE). BY DOING THIS, EACH ROUTINE IS ALMOST * 01740000
* INDEPENDENT OF OTHER FUNCTIONS AND THUS MAY BE REMOVED * 01750000
* OR OTHERS ADDED WITH LITTLE CONCERN FOR DUPLICATION AND/OR * 01760000
* RELATIONAL DEPENDENCIES. * 01770000
* * 01780000
*********************************************************************** 01790000
MVSGPSVC AMODE 31 01800009
MVSGPSVC RMODE ANY 01810010
MVSGPSVC CSECT 01820000
USING MVSGPSVC,R6 USE R6 FOR CSECT BASE REGISTER 01830000
USING CVT,R3 PERPETUAL USE R3 FOR CVT DSECT BASE REG 01840000
USING TCB,R4 PERPETUAL USE R4 FOR TCB DSECT BASE REG 01850000
USING ASCB,R7 PERPETUAL USE R7 FOR ASCB DSECT BASE REG 01860000
LTR R15,R15 CHECK FOR POSITIVE EP INDICATOR 01870000
BNP NOP IF NOT POSITIVE, GO TO NOP 01880000
LA R2,EPCNT LOAD R2 WITH NO OF VALID EP'S 01890000
CR R15,R2 CHECK FOR VALID EP INDICATOR 01900000
BH NOP IF INVALID, GO TO NOP 01910000
SLL R15,2 MULTIPLY EP INDICATOR BY 4 01920000
L R6,EPTABLE-4(R15) SET R6=A(ROUTINE ENTRY POINT) 01930000
BR R6 GO TO APPROPRIATE ENTRY POINT 01940000
NOP BR R14 RETURN TO SVC HANDLER 01950000
* 01960000
EPTABLE DC A(SVCTEST) 1 SVCTEST ROUTINE 01970000
DC A(TIME) 2 TIME ROUTINE 01980000
DC A(AUTHSET) 3 AUTHSET ROUTINE 01990000
DC A(AUTHRSET) 4 AUTHRSET ROUTINE 02000000
DC A(SMFWTM) 5 SMFWTM ROUTINE 02010000
DC A(UCBLOOK) 6 UCBLOOK ROUTINE 02020000
DC A(JCTLOOK) 7 JCTLOOK ROUTINE 02030000
DC A(JESJOBID) 8 JESJOBID ROUTINE 02040000
DC A(JESINDEV) 9 JESINDEV ROUTINE 02050000
DC A(CLEAR) 10 TSO CLEAR SCREEN ROUTINE 02060000
DC A(CALJUL) 11 DATE CONVERSION ROUTINE 02070000
DC A(JULCAL) 12 DATE CONVERSION ROUTINE 02080000
DC A(JULDIF) 13 DATE DIFFERENCE ROUTINE 02090000
DC A(NOP) 14 (UNUSED AT THIS TIME) 02100000
DC A(XACF) 15 (UNUSED AT THIS TIME) 02110000
DC A(NOP) 16 (UNUSED AT THIS TIME) 02120000
DC A(NOP) 17 (UNUSED AT THIS TIME) 02130000
DC A(NOP) 18 (UNUSED AT THIS TIME) 02140000
DC A(NOP) 19 (UNUSED AT THIS TIME) 02150000
EPCNT EQU (*-EPTABLE)/4 NUMBER OF VALID ENTRY POINTS 02160000
LTORG 02170000
DROP R6 DROP USE OF R6 BASE REGISTER 02180000
*********************************************************************** 02190000
* * 02200000
* THE FOLLOWING ARE THE MVS GP SVC SUBROUTINES * 02210000
* * 02220000
*********************************************************************** 02230000
EJECT 02240000
*********************************************************************** 02250000
* * 02260000
* THIS ROUTINE SETS UP THE ENVIRONMENT TO TEST USER * 02270000
* WRITTEN SVC'S. IN ORDER TO USE THIS FUNCTION, A DRIVER * 02280000
* PROGRAM MUST BE USED WHICH WILL POINT R1 AT A FOUR WORD * 02290000
* LIST WHICH CONTAINS THE ENTRY POINT OF THE PRELOADED SVC * 02300000
* MODULE FOLLOWED BY VALUES FOR R15/0/1 AS THEY SHOULD BE * 02310000
* AT ENTRY TO THE SVC. THIS ROUTINE MERELY LOADS R6 WITH * 02320000
* WORD0, R15 WITH WORD1, R0 WITH WORD2, R1 WITH WORD3, AND * 02330000
* BRANCHES ON R6. * 02340000
* * 02350000
* REGISTERS UPON ENTRY. * 02360000
* R0 = IGNORED * 02370000
* R1 = ADDRESS OF 4 WORD AREA, FULLWORD ALLIGNED * 02380000
* A(BASE) A(PARM-R15) A(PARM-R1) A(PARM-R0) * 02390000
* R15 = 1 * 02400000
* * 02410000
* REGISTERS UPON RETURN. * 02420000
* R0 = DETERMINED BY SVC UNDER TEST * 02430000
* R1 = DETERMINED BY SVC UNDER TEST * 02440000
* R15 = DETERMINED BY SVC UNDER TEST * 02450000
* * 02460000
*********************************************************************** 02470000
SVCTEST DS 0H SVCTEST ENTRY 02480000
USING SVCTEST,R6 BASE FOR SUBROUTINE 02490000
USING PSCB,R10 ESTABLISH ADDRESSABILITY 02500000
USING IEZJSCB,R11 ESTABLISH ADDRESSABILITY 02510000
L R11,TCBJSCB GET JSCB ADDRESS 02520000
ICM R15,15,ASCBTSB GET TSB ADDRESS 02530000
BZ SVCTERR NO TSB = BATCH, NOT SUPPORTED 02540000
L R10,JSCBPSCB GET PSCB ADDRESS 02550000
TM PSCBATR1,X'80' CHECK FOR OPER CAPABILITY 02560000
BZ SVCTERR NO, INVALID REQUEST 02570000
L R6,0(R1) SET UP BASE FOR TEST ROUTINE 02580000
LM R15,R1,4(R1) SET UP R15,R0,R1 FOR TEST ROUTINE 02590000
BR R6 BRANCH TO PRELOADED SVC 02600000
SVCTERR L R15,=F'-1' SET RETURN CODE 02610000
LR R0,R15 COPY TO R0 02620000
LR R1,R15 AND TO R1 02630000
BR R14 AND GIVE IT TO HIM 02640000
LTORG 02650000
DROP R10 DROP DSECT ADDRESSABILITY 02660000
DROP R11 DROP DSECT ADDRESSABILITY 02670000
DROP R6 DROP USE OF R6 BASE REGISTER 02680000
EJECT 02690000
*********************************************************************** 02700000
* * 02710000
* THIS ROUTINE SUPPLIES THE REQUESTOR WITH THE DATE, DAY * 02720000
* OF WEEK, AND TIME. IF THE CURRENT TIME IS NEEDED, REG1 * 02730000
* UPON ENTRY MUST BE A POSITIVE ADDRESS AND POINT TO A 5 * 02740000
* WORD AREA ALLIGNED ON A DOUBLEWORD. IF TIME IS TO BE * 02750000
* OBTAINED FROM A PREVIOUS STCK INSTRUCTION, REG1 UPON * 02760000
* ENTRY MUST BE NEGATIVE AND ITS COMPLIMENT MUST POINT TO * 02770000
* A 7 WORD AREA ALLIGNED ON A DOUBLEWORD, THE FIRST 2 * 02780000
* WORDS CONTAINING THE STCK DATA. THE STORAGE AREA * 02790000
* POINTED TO BY REG1 IS CHECKED FOR VALIDITY AND * 02800000
* ALLIGNMENT. * 02810000
* * 02820000
* REGISTERS UPON ENTRY. * 02830000
* CURRENT TIME REQUEST. * 02840000
* R0 = UNUSED * 02850000
* R1 = ADDRESS OF 5 WORD AREA, DOUBLEWORD ALLIGNED * 02860000
* R15 = 2 * 02870000
* STCK DATA SUPPLIED. * 02880000
* R0 = UNUSED * 02890000
* R1 = COMPLIMENT OF ADDRESS OF 7 WORD AREA, * 02900000
* DOUBLEWORD ALLIGNED * 02910000
* R15 = 2 * 02920000
* * 02930000
* REGISTERS UPON RETURN. * 02940000
* AREA VALID AND PROPERLY ALLIGNED. * 02950000
* R0 = UNCHANGED * 02960000
* R1 = UNCHANGED * 02970000
* R15 = 0 * 02980000
* RETURN AREA. * 02990000
* +0 = MM/DD/YY DATE * 03000000
* +8 = X DAY OF WEEK OFFSET (0=MONDAY) * 03010000
* +9 = HH.MM.SS.TH TIME * 03020000
* AREA NOT VALID OR NOT PROPERLY ALLIGNED. * 03030000
* R0 = UNCHANGED * 03040000
* R1 = UNCHANGED * 03050000
* R15 = 8 * 03060000
* RETURN AREA. * 03070000
* UNCHANGED * 03080000
* * 03090000
*********************************************************************** 03100000
TIME DS 0H TIME ENTRY 03110000
USING TIME,R6 BASE FOR SUBROUTINE 03120000
USING RBBASIC,R5 ESTABLISH ADDRESSABILITY 03130000
USING TWORK,R15 ESTABLISH ADDRESSABILITY 03140000
TIME1000 LR R8,R1 SET R8=A(PASSED AREA) 03150000
LR R15,R1 SET R15=A(ANSWER AREA) 03160000
LTR R8,R8 CHECK FOR NEGATIVE 03170000
BNM TIME1100 IF NOT NEGATIVE, GO TO TIME1100 03180000
LCR R8,R8 SET ADDRESS POSITIVE 03190000
LA R15,8(R8) SET R15=A(ANSWER AREA) 03200000
TIME1100 SR R9,R9 RESET R9 FOR DOUBLE SHIFT 03210000
SRDL R8,3 SHIFT FOR ALLIGNMENT TEST 03220000
LTR R9,R9 CHECK R9 FOR ANY BITS ON 03230000
BNZ TIMERT08 IF ANY ON, NOT ALLIGNED, GO TO 8 RT 03240000
SRDL R8,29 SHIFT REST FOR USE AS ADDRESS 03250000
L R5,RBLINK SET R5=A(PREVIOUS RB) 03260000
IC R8,RBOPSW+1 SET R9=REQUESTOR'S PROTECT KEY 03270000
SRL R8,3 SHIFT OUT UNUSED BITS 03280000
BAL R2,TIME1900 LINK TO VALIDITY CHECK ROUTINE 03290000
LA R9,23(R15) SET R8=A(LAST BYTE IN AREA) 03300000
BAL R2,TIME1900 LINK TO VALIDITY CHECK ROUTINE 03310000
B TIME2000 GO TO TIME2000 03320000
TIME1900 LRA R9,0(R9) LOAD REAL ADDRESS INTO R9 03330000
BNZ TIMERT08 IF INVALID, GO TO 8 RETURN 03340000
LTR R8,R8 CHECK FOR REQUESTOR IN KEY0 03350000
BZR R2 IF KEY0, RETURN TO INVOKING AREA 03360000
SRL R9,4 SHIFT TO ZERO UNWANTED REAL BITS 03370000
SLL R9,4 RESTORE WITH BITS 28-31=0 03380000
SR R10,R10 RESET R10 FOR SUBSEQUENT ISK 03390000
ISK R10,R9 INSERT STORAGE KEY INTO R10 03400000
SRL R10,3 SHIFT OUT UNUSED BITS FOR COMPARE 03410000
CR R8,R10 CHECK FOR KEY MATCH 03420000
BER R2 IF EQUAL, RETURN TO INVOKING AREA 03430000
B TIMERT08 IF NO MATCH, GO TO 8 RETURN 03440000
TIME2000 LCR R8,R1 SET R8=0-R1 03450000
BNM TIME2110 IF NOT NEG, R1 NEG, GO TO TIME2110 03460000
TIME2100 STCK TW00L08 STORE CLOCK IN TW00L08 03470000
L R8,CVTTZ SET R8=CVTTZ, TIME ZONE DIFFERENTIAL 03480000
B TIME2120 GO TO TIME2120 03490000
TIME2110 MVC TW00L08,0(R8) MOVE PASSED STCK DATA TO TW00L08 03500000
SR R8,R8 SET R8=0, TIME ZONE DIFFERENTIAL 03510000
TIME2120 A R8,TW00L04 ADD STCK DATA WORD 0 TO R8 03520000
L R9,TW04L04 SET R9=STCK DATA WORD 1 03530000
SRDL R8,12 SET R8,R9=TIME IN MICROSECONDS 03540000
AL R9,CTIF5000 ADD 5000 MSECS FOR ROUNDING 03550000
BC 12,TIME2130 IF NO CARRY, GO TO TIME2130 03560000
AH R8,CTIH0001 ADD 1 TO R8 FOR CARRY 03570000
TIME2130 D R8,CTIF060M SET R8=REM MSECS, R9=MINS 03580000
SR R10,R10 RESET R10 FOR SUBSEQUENT DIVIDE 03590000
LR R11,R8 SET R8=REM MSECS 03600000
D R10,CTIF010K SET R11=HSECS 03610000
CVD R11,TW00L08 CONVERT HSECS TO DECIMAL 03620000
UNPK TW16L04,TW00L08 UNPACK INTO BYTE 16 03630000
MVC TW15L02,TW16L02 MOVE SECS TO ANSWER AREA 03640000
SR R8,R8 RESET R8 FOR SUBSEQUENT DIVIDE 03650000
D R8,CTIF0060 SET R8=REM MINS, R9=HRS 03660000
CVD R8,TW00L08 CONVERT MINS TO DECIMAL 03670000
UNPK TW12L02,TW00L08 UNPACK MINS INTO ANSWER AREA 03680000
SR R8,R8 RESET R8 FOR SUBSEQUENT DIVIDE 03690000
D R8,CTIF0024 SET R8=REM HRS, R9=DAYS 03700000
CVD R8,TW00L08 CONVERT HRS TO DECIMAL 03710000
UNPK TW09L02,TW00L08 UNPACK HRS INTO ANSWER AREA 03720000
TIME2200 SR R10,R10 RESET R10 FOR SUBSEQUENT DIVIDE 03730000
LR R11,R9 SET R11=DAYS 03740000
D R10,CTIF0007 SET R10=DAY OF WEEK OFFSET 03750000
STC R10,TW08L01 SAVE BINARY OFFSET IN ANSWER AREA 03760000
TIME2300 SH R9,CTIH0365 SUBTRACT 365 DAYS FOR 1900 03770000
BNM TIME2310 IF NOT NEG, GO TO TIME2310 03780000
AH R9,CTIH0365 ADD 365 DAYS FOR 1900 03790000
SLDL R8,32 SET R8=JDAY-1, R9=00, YEAR 03800000
B TIME2340 GO TO TIME2340 03810000
TIME2310 SR R8,R8 RESET R8 FOR SUBSEQUENT DIVIDE 03820000
D R8,CTIF1461 SET R8=JDAY (4YR), R9=4YR COUNT-1 03830000
SLL R9,2 SET R9=YR-1 03840000
LA R9,1(R9) SET R9=YR 03850000
LA R12,3 SET R12=3, BCT COUNT 03860000
TIME2320 SH R8,CTIH0365 SUBTRACT 1 YR'S DAYS 03870000
BM TIME2330 IF NEG, GO TO TIME2330 03880000
LA R9,1(R9) INCREMENT R9, YR 03890000
BZ TIME2340 IF R8=0, GO TO TIME2340 03900000
BCT R12,TIME2320 GO BACK TO TIME2320 AT MOST 2 TIMES 03910000
B TIME2340 AFTER 2ND TIME, GO TO TIME2340 03920000
TIME2330 AH R8,CTIH0365 ADD TO MAKE NEG POS 03930000
TIME2340 LA R8,1(R8) MAKE JDAY RELATIVE TO 1 03940000
CVD R9,TW00L08 CONVERT YR TO DECIMAL 03950000
UNPK TW06L02,TW06L02 UNPACK YEAR 03960000
ICM R11,3,TW06L02 SAVE UNPACKED YR IN R11 03970000
LA R12,TDTBLNLP SET R12=A(NON-LEAP YEAR TABLE) 03980000
SLL R9,30 SHIFT OUT BITS 0-29 03990000
LTR R9,R9 CHECK FOR ANY REMAINING BITS 04000000
BNZ TIME2350 IF ANY LEFT, GO TO TIME2350 04010000
LA R12,TDTBLLP SET R12=A(LEAP YEAR TABLE) 04020000
TIME2350 SR R10,R10 RESET R10 FOR SUBSEQUENT IC'S 04030000
TIME2360 IC R10,0(R9,R12) SET R10=DA/MO FROM TABLE 04040000
LA R9,1(R9) INCREMENT R9, MONTH 04050000
SR R8,R10 SUBTRACT DA/MO FROM R8 DA 04060000
BP TIME2360 IF STILL POS, GO TO TIME2360 04070000
AR R8,R10 ADD DA/MO TO MAKE POS 04080000
CVD R8,TW00L08 CONVERT DA TO DECIMAL 04090000
UNPK TW06L02,TW06L02 UNPACK DA 04100000
ICM R11,12,TW06L02 SAVE UNPACKED DA IN R11 04110000
CVD R9,TW00L08 CONVERT MO TO DECIMAL 04120000
UNPK TW00L02,TW06L02 UNPACK MO INTO ANSWER AREA 04130000
STCM R11,12,TW03L02 STORE DA INTO ANSWER AREA 04140000
STCM R11,3,TW06L02 STORE YR INTO ANSWER AREA 04150000
MVZ TW01L19,TW00L19 MOVE ALL F ZONES TO ANSWER AREA 04160000
MVI TW02L01,C'/' MOVE '/' BETWEEN DATE MM DD 04170000
MVI TW05L01,C'/' MOVE '/' BETWEEN DATE DD YY 04180000
NI TW08L01,X'0F' AND OFF F ZONE 04190000
MVI TW11L01,C'.' MOVE '.' BETWEEN TIME HH MM 04200000
MVI TW14L01,C'.' MOVE '.' BETWEEN TIME MM SS 04210000
MVI TW17L01,C'.' MOVE '.' BETWEEN TIME SS TH 04220000
TIMERT00 SR R15,R15 SET RETURN CODE=0 04230000
BR R14 RETURN TO SVC HANDLER 04240000
TIMERT08 LA R15,8 SET RETURN CODE=8 04250000
BR R14 RETURN TO SVC HANDLER 04260000
CTIF0007 DC F'7' 04270000
CTIF0024 DC F'24' 04280000
CTIF0060 DC F'60' 04290000
CTIF1461 DC F'1461' 04300000
CTIF5000 DC F'5000' 04310000
CTIF010K DC F'10000' 04320000
CTIF060M DC F'60000000' 04330000
CTIH0001 DC H'1' 04340000
CTIH0365 DC H'365' 04350000
TDTBLLP DC AL1(31,29,31,30,31,30,31,31,30,31,30,31) 04360000
TDTBLNLP DC AL1(31,28,31,30,31,30,31,31,30,31,30,31) 04370000
LTORG 04380000
DROP R5 DROP USE OF R5 DSECT BASE REGISTER 04390000
DROP R6 DROP USE OF R6 BASE REGISTER 04400000
DROP R15 DROP USE OF R15 DSECT BASE REGISTER 04410000
EJECT 04420000
*********************************************************************** 04430000
* * 04440000
* THIS ROUTINE WILL PROVIDE MODESET AUTHORIZATION. IT IS * 04450000
* THEN THE USER'S RESPONSIBILITY TO ISSUE A MODESET MACRO * 04460000
* IN ORDER TO GAIN SUPERVISOR STATE OR KEY ZERO. UPON * 04470000
* ENTRY REGISTER ONE MUST POINT TO THE CHARACTERS 'AUTH'. * 04480000
* FOR TIME SHARING USERS ONLY, THE ISSUER OF THE SVC * 04490000
* (CALLER) MUST EITHER HAVE OPER CAPABILITY OR RESIDE IN * 04500000
* THE LINK PACK AREA (OR MLPA). THIS IS TO INSURE THAT * 04510000
* TSO USERS DO NOT ATTEMPT TO VIOLATE OUR SECURITY BY * 04520000
* INVOKING EITHER DIRECTLY OR UNDER TEST. * 04530000
* * 04540000
* REGISTERS UPON ENTRY. * 04550000
* R0 = UNUSED * 04560000
* R1 = ADDRESS 'AUTH' LITERAL * 04570000
* R15 = 3 * 04580000
* * 04590000
* REGISTERS UPON RETURN. * 04600000
* R1 UPON ENTRY ==> C'AUTH' AND (USER HAS OPER OR NON TSO) * 04610000
* R0 = UNCHANGED * 04620000
* R1 = UNCHANGED * 04630000
* R15 = 0 * 04640000
* JSCBOPTS, BIT 7 SET * 04650000
* R1 UPON ENTRY NOT ==> C'AUTH' OR INVALID TSO USER * 04660000
* R0 = UNCHANGED * 04670000
* R1 = UNCHANGED * 04680000
* R15 = 8 * 04690000
* VIOLATION MESSAGE WRITTEN TO OPERATOR * 04700000
* * 04710000
*********************************************************************** 04720000
AUTHSET DS 0H AUTHSET ENTRY 04730000
USING WTO,R1 ESTABLISH ADDRESSABILITY 04740000
USING RBBASIC,R5 ESTABLISH ADDRESSABILITY 04750000
USING AUTHSET,R6 BASE FOR SUBROUTINE 04760000
USING PSCB,R10 ESTABLISH ADDRESSABILITY 04770000
USING IEZJSCB,R11 ESTABLISH ADDRESSABILITY 04780000
USING TIOT,R12 ESTABLISH ADDRESSABILITY 04790000
LR R8,R0 SAVE R0 IN R8 04800000
LR R9,R1 SAVE R1 IN R9 04810000
CLC AUTH,0(R1) CHECK FOR R1 POINTING AT 'AUTH' 04820000
BNE AUTSRT08 IF NOT, GO TO 8 RETURN 04830000
L R11,TCBJSCB SET R11=A(JSCB) 04840000
ICM R15,15,ASCBTSB SET R15=A(TSB) 04850000
BZ AUTSRT00 IF NOT TSO, GO TO 0 RETURN 04860000
L R10,JSCBPSCB SET R10=A(PSCB) 04870000
TM PSCBATR1,X'80' CHECK FOR OPER CAPABILITY 04880000
BO AUTSRT00 IF OPER, GO TO 0 RETURN 04890000
L R5,RBLINK SET R5=A(PREVIOUS RB) 04900000
L R15,RBOPSW+4 GET INTERUPT ADDRESS FROM RB PSW 04910000
TM CVTDCB,X'80' IS THIS MVS XA ? 04920000
BO AUTCHK01 YES, CHECK ADDRESS 04930000
AUTCHK00 LA R15,0(R15) CLEAR HIGH ORDER BYTE 04940000
C R15,CVTSHRVM CHECK FOR REQ FROM CSA OR ABOVE 04950000
BL AUTSRT08 BELOW CSA, INVALID REQUEST 04960000
B AUTSRT00 ABOVE, ALLOW REQUEST 04970000
AUTCHK01 TM RBOPSW+4,X'80' EXECUTING IN 31 BIT MODE? 04980000
BZ AUTCHK00 NO, CHECK ADDRESS 04990000
N R15,MASK31 STIP HIGH ORDER BIT 05000000
C R15,CVTSHRVM CHECK FOR REQ FROM CSA OR ABOVE 05010000
BL AUTSRT08 BELOW CSA, INVALID REQUEST 05020000
* L R10,CVTVSTGX ADDRESS OF XA STG MAP 05030000
L R10,X'4AC'(R3) ( COMPATIBILITY WITH SP1.3 ) 05040000
* USING CVTVSTGX,R10 ADDRESSABILITY 05050000
* C R15,CVTEMLPE CHECK IF BEYOND EXTENDED MLPA 05060000
C R15,X'4C'(R10) ( COMPATIBILITY WITH SP1.3 ) 05070000
BH AUTSRT08 ABOVE EXTENDED MLPA, INVALID REQ 05080000
AUTSRT00 OI JSCBOPTS,X'01' SET MODESET AVAILABLE BIT 05090000
SR R15,R15 SET R15=0, RETURN CODE 05100000
BR R14 RETURN TO SVC HANDLER 05110000
AUTSRT08 LA R0,256 SET R0=256, GETMAIN LENGTH 05120000
GETMAIN R,LV=(0) GET STORAGE FOR WTO 05130000
LR R2,R1 SAVE AREA ADDRESS IN R2 05140000
MVC WTO(CAUWTOLN),CAUWTO MOVE WTO DATA TO GOTTEN AREA 05150000
L R12,TCBTIO SET R12=A(TIOT) 05160000
MVC WTOMSG+30(8),TIOCNJOB MOVE JOBNAME TO WTOMSG 05170000
WTO MF=(E,(1)) ISSUE WTO 05180000
LA R0,256 SET R0=256, FREEMAIN LENGTH 05190000
LR R1,R2 SET R1=A(GOTTEN AREA) 05200000
FREEMAIN R,LV=(0),A=(1) FREE GOTTEN STORAGE 05210000
LR R0,R8 RESTORE ORIGINAL R0 FROM R8 05220000
LR R1,R9 RESTORE ORIGINAL R1 FROM R9 05230000
LA R15,8 SET R15=8, RETURN CODE 05240000
BR R14 RETURN TO SVC HANDLER 05250000
CAUWTO DC 0F'0',AL2(CAUWTOLN-4),XL2'8000' TEXT LENGTH, MCS CODES 05260000
DC CL50'SECURITY VIOLATION ATTEMPT BY XXXXXXXX - NOTIFY TE' 05270000
DC CL15'CHNICAL SUPPORT' 05280000
DC XL4'4000C080' DESCRIPTOR CODES, ROUT CODES 05290000
CAUWTOLN EQU *-CAUWTO 05300000
AUTH DC CL4'AUTH' 05310000
DS 0F 05320000
MASK31 DC X'7FFFFFFF' 05330000
MVSGPSVC CSECT 05340000
LTORG 05350000
DROP R1 DROP USE OF R1 BASE REGISTER 05360000
DROP R5 DROP USE OF R5 BASE REGISTER 05370000
DROP R6 DROP USE OF R6 BASE REGISTER 05380000
DROP R10 DROP USE OF R10 BASE REGISTER 05390000
DROP R11 DROP USE OF R11 BASE REGISTER 05400000
DROP R12 DROP USE OF R12 BASE REGISTER 05410000
EJECT 05420000
*********************************************************************** 05430000
* * 05440000
* THIS ROUTINE WILL DISALLOW MODESET AUTHORIZATION. * 05450000
* * 05460000
* REGISTERS UPON ENTRY. * 05470000
* R0 = UNUSED * 05480000
* R1 = UNUSED * 05490000
* R15 = 4 * 05500000
* * 05510000
* REGISTERS UPON RETURN. * 05520000
* R0 = UNCHANGED * 05530000
* R1 = UNCHANGED * 05540000
* R15 = 0 * 05550000
* JSCBOPTS, BIT 7 RESET * 05560000
* * 05570000
*********************************************************************** 05580000
AUTHRSET DS 0H AUTHRSET ENTRY 05590000
USING AUTHRSET,R6 BASE FOR SUBROUTINE 05600000
USING IEZJSCB,R11 ESTABLISH ADDRESSABILITY 05610000
L R11,TCBJSCB SET R11=A(JSCB) 05620000
NI JSCBOPTS,X'FE' RESET MODESET AVAILABLE BIT 05630000
SR R15,R15 SET R15=0, RETURN CODE 05640000
BR R14 RETURN TO SVC HANDLER 05650000
LTORG 05660000
DROP R6 DROP USE OF R6 BASE REGISTER 05670000
DROP R11 DROP USE OF R11 BASE REGISTER 05680000
EJECT 05690000
*********************************************************************** 05700000
* * 05710000
* THIS ROUTINE ISSUES THE SMFWTM (SMF WRITE MACRO) FOR A * 05720000
* SMF RECORD POINTED TO BY R1. IT CAN BE USED BY ANY * 05730000
* MODULE WITHOUT HAVING TO BE AUTHORIZED TO OBTAIN * 05740000
* SUPERVISOR MODE. * 05750000
* * 05760000
* REGISTERS UPON ENTRY. * 05770000
* R0 = UNUSED * 05780000
* R1 = ADDRESS OF SMF RECORD * 05790000
* R15 = 5 * 05800000
* * 05810000
* REGISTERS UPON RETURN. * 05820000
* R0 = UNCHANGED * 05830000
* R1 = UNCHANGED * 05840000
* R15 = 0 WRITTEN WITHOUT ERROR * 05850000
* R15 = 4 NOT WRITTEN, WOULD NOT FIT IN EMPTY D.S. * 05860000
* R15 = 8 NOT WRITTEN, RDW LENGTH LESS THAN 18 * 05870000
* R15 = 16 NOT WRITTEN, MAN=NONE OR BOTH D.S. FULL * 05880000
* R15 = 20 NOT WRITTEN, IEFU83 SUPPRESSED WRITE * 05890000
* * 05900000
*********************************************************************** 05910000
SMFWTM DS 0H SMFWTM ENTRY 05920000
USING SMFWTM,R6 BASE FOR SUBROUTINE 05930000
LR R8,R0 SAVE R0 IN R8 05940000
LR R9,R1 SAVE R1 IN R9 05950000
SMFWTM (1) WRITE SMF RECORD POINTED TO BY R1 05960000
LR R0,R8 RESTORE R0 FROM R8 05970000
LR R1,R9 RESTORE R1 FROM R9 05980000
BR R14 RETURN TO SVC HANDLER 05990000
LTORG 06000000
DROP R6 DROP USE OF R6 BASE REGISTER 06010000
EJECT 06020000
*********************************************************************** 06030000
* * 06040000
* THIS ROUTINE SUPPLIES THE REQUESTOR WITH THE UCB * 06050000
* ADDRESS OF THE UCB WHOSE EBCDIC VALUE IS PASSED IN THE * 06060000
* LOW ORDER THREE BYTES OF R0. * 06070000
* * 06080000
* REGISTERS UPON ENTRY. * 06090000
* R0 = EBCDIC UCB NAME ('.1A8' = X'..F1C1F8') * 06100000
* R1 = UNUSED * 06110000
* R15 = 6 * 06120000
* * 06130000
* REGISTERS UPON RETURN. * 06140000
* UCB FOUND. * 06150000
* R0 = EBCDIC UCB NAME IN LOW ORDER 3 BYTES * 06160000
* R1 = ADDRESS OF UCB * 06170000
* R15 = 0 * 06180000
* UCB NOT FOUND. * 06190000
* R0 = -1 * 06200000
* R1 = -1 * 06210000
* R15 = 8 * 06220000
* * 06230000
*********************************************************************** 06240000
UCBLOOK DS 0H UCBLOOK ENTRY 06250000
USING UCBLOOK,R6 BASE FOR SUBROUTINE 06260000
USING UCBDSECT,R11 ESTABLISH ADDRESSABILITY 06270000
USING UCBWORK,R13 ESTABLISH ADDRESSABILITY 06280000
LR R8,R0 SAVE R0 IN R8 06290000
LR R9,R1 SAVE R1 IN R9 06300000
LR R12,R14 SAVE R14 IN R12 06310000
LA R0,UCBWORKE-UCBWORK SET SIZE FOR GETMAIN 06320000
GETMAIN R,LV=(0) GET SOME STORAGE 06330000
LR R13,R1 ADDRESS OF UCBWORK TO BASE REG 06340000
XC UCBWORKS(UCBWORKE-UCBWORK),UCBWORK CLEAR WORK AREA 06350000
LA R1,UCBWORKS ADDRESS OF WORK AREA FOR UCB SCAN 06360000
ST R1,UCBPARML PLACE INTO PARM LIST 06370000
LA R1,UCBDEVCL ADDRESS OF DEVICE CLASS (NULL) 06380000
ST R1,UCBPARML+4 PLACE INTO PARM LIST 06390000
LA R1,UCBADDR ADDRESS OF RETURN FIELD 06400000
ST R1,UCBPARML+8 PLACE INTO PARM LIST 06410000
OI UCBPARML+8,128 SET HIGH ORDER BIT 06420000
* 06430000
* SCAN EACH UCB VIA IOSVSUCB AND CHECK FOR REQUESTED NAME 06440000
* 06450000
UCBLOOP EQU * 06460000
LA R1,UCBPARML PARAMETER LIST FOR IOSUCBSV 06470000
L R15,CVTUCBSC UCB SERVICE ROUTINE ADDRESS 06480000
BALR R14,R15 CALL UCB SERVICE ROUTINE 06490000
LTR R15,R15 ANY UCB FOUND? 06500000
BNZ UCBERR NO, REQUESTED NOT FOUND 06510000
L R9,UCBADDR PICK UP UCB ADDR 06520000
CLM R8,7,13(R9) RIGHT UCB ? 06530000
BNE UCBLOOP NO - CHECK NEXT ENTRY 06540000
SR R10,R10 FOUND, RESET RETCODE 06550000
B UCBDONE AND EXIT 06560000
UCBERR L R8,=F'-1' NOT FOUND 06570000
L R9,=F'-1' NOT FOUND 06580000
LA R10,8 NOT FOUND 06590000
UCBDONE LA R0,UCBWORKE-UCBWORK SET SIZE FOR GETMAIN 06600000
LA R1,UCBWORK SET R1=A(GETMAIN AREA) 06610000
FREEMAIN R,LV=(0),A=(1) FREE GOTTEN STORAGE 06620000
LR R0,R8 RESTORE ORIGINAL R0 FROM R8 06630000
LR R1,R9 RESTORE ORIGINAL R1 FROM R9 06640000
LR R14,R12 RESTORE ORIGINAL R14 FROM R12 06650000
LR R15,R10 SET R15=RETURN CODE 06660000
BR R14 RETURN TO SVC HANDLER 06670000
LTORG 06680000
UCBDEVCL DC XL1'00' UCB DEVICE CLASS (ALL DEVICES) 06690000
UCBWORK DSECT 06700000
UCBSAVE DS 18F REG SAVE AREA FOR IOSVSUCB 06710000
UCBADDR DS F ADDRESS OF RETURNED UCB 06720000
UCBPARML DS A IOSVSUCB PARM - ADDR OF UCBWORK 06730000
DS A IOSVSUCB PARM - ADDR OF DEVICE CLASS 06740000
DS A IOSVSUCB PARM - UCB ADDRESS POINTER 06750000
DS F IOSVSUCB RETURNED UCB ADDRESS 06760000
UCBWORKS DS XL100 IOSVSUCB WORK AREA 06770000
UCBWORKE EQU * END OF UCBWORK 06780000
MVSGPSVC CSECT 06790000
DROP R6 DROP USE OF R6 BASE REGISTER 06800000
DROP R11 DROP USE OF R11 DSECT BASE REGISTER 06810000
EJECT 06820000
----------------------------------------------------------------------
For IBM-MAIN subscribe / signoff / archive access instructions,
send email to [email protected] with the message: INFO IBM-MAIN
