Here is second part of my code. ---------------------------------------------------------------------- For IBM-MAIN subscribe / signoff / archive access instructions, send email to [email protected] with the message: INFO IBM-MAIN
*********************************************************************** 06830000
* * 06840000
* THIS ROUTINE WILL PROVIDE THE JCT ADDRESS FOR A JOB, * 06850000
* PROVIDE THE ADDRESS OF THE 7 BYTE TSO USER ID IF THE * 06860000
* JOB CARD CONTAINS A NOTIFY= PARAMETER, AND CHECKS FOR * 06870000
* THAT USER BEING LOGGED ON. * 06880000
* * 06890000
* REGISTERS UPON ENTRY. * 06900000
* R0 = UNUSED * 06910000
* R1 = UNUSED * 06920000
* R15 = 7 * 06930000
* * 06940000
* REGISTERS UPON RETURN. * 06950000
* NOTIFY SPECIFIED, NOTIFY TSO USER LOGGED ON * 06960000
* R0 = A(TSO TSU ID) * 06970000
* R1 = A(JCT) * 06980000
* R15 = 0 * 06990000
* NOTIFY SPECIFIED, NOTIFY TSO USER NOT LOGGED ON * 07000000
* R0 = A(TSO TSU ID) * 07010000
* R1 = A(JCT) * 07020000
* R15 = 4 * 07030000
* NOTIFY NOT SPECIFIED * 07040000
* R0 = 0 * 07050000
* R1 = A(JCT) * 07060000
* R15 = 8 * 07070000
* INVALID CONTROL BLOCK STRUCTURE (JCT NOT FOUND) * 07080000
* R0 = UNPREDICTABLE * 07090000
* R1 = UNPREDICTABLE * 07100000
* R15 = 16 * 07110000
* * 07120000
*********************************************************************** 07130000
JCTLOOK DS 0H JCTLOOK ENTRY 07140000
USING JCTLOOK,R6 BASE FOR SUBROUTINE 07150000
USING ASVT,R12 ESTABLISH ADDRESSABILITY 07160000
USING JCT,R10 ADDRESSABILITY ESTABLISHED IN $JCT 07170006
JCTGET GET JCT ADDRESS 07180000
CLI JCTTSUID,X'00' CHECK FOR NO NOTIFY 07190000
BE JCTLRT08 IF NULL, NONE, GO TO 8 RETURN 07200000
L R12,CVTASVT SET R12=A(ASVT) FROM CVT 07210000
L R0,ASVTMAXU SET R0=MAX # OF ASCB'S FROM ASVT 07220000
JCTL1100 ICM R7,15,ASVTENTY SET R7=A(ASCB) FROM ASVT 07230000
BM JCTL1200 IF NOT ASSIGNED, GO TO JCTL1200 07240000
ICM R1,15,ASCBTSB SET R1=A(TSB) FROM ASCB 07250000
BZ JCTL1200 IF 0, NOT TSO, GO TO JCTL1200 07260000
L R15,ASCBJBNS SET R15=A(JOBNAME) FROM ASCB 07270000
CLC JCTTSUID,0(R15) CHECK FOR TSO USER LOGGED ON 07280000
BE JCTLRT00 IF LOGGED ON, GO TO JCTLRT00 07290000
JCTL1200 LA R12,4(R12) INCREMENT R12, ASVT DSECT BASE 07300000
BCT R0,JCTL1100 CONTINUE CHECKING AT JCTL1100 07310000
B JCTLRT04 USER NOT LOGGED ON, GO TO JCTLRT04 07320000
JCTLRT00 EQU * 07330000
LA R0,JCTTSUID SET R0=A(NOTIFY TSUID) 07340000
LA R1,JCTSTART SET R1=A(JCT) 07350000
SR R15,R15 SET R15=0, RETURN CODE 07360000
BR R14 RETURN TO SVC HANDLER 07370000
JCTLRT04 EQU * 07380000
LA R0,JCTTSUID SET R0=A(NOTIFY TSUID) 07390000
LA R1,JCTSTART SET R1=A(JCT) 07400000
LA R15,4 SET R15=4, RETURN CODE 07410000
BR R14 RETURN TO SVC HANDLER 07420000
JCTLRT08 SR R0,R0 SET R0=0, NO NOTIFY 07430000
LA R1,JCTSTART SET R1=A(JCT) 07440000
LA R15,8 SET R15=8, RETURN CODE 07450000
BR R14 RETURN TO SVC HANDLER 07460000
LTORG 07470000
DROP R6 DROP USE OF R6 BASE REGISTER 07480000
DROP R10 DROP USE OF R10 BASE REGISTER 07490000
DROP R12 DROP USE OF R12 BASE REGISTER 07500000
EJECT 07510000
*********************************************************************** 07520000
* * 07530000
* THIS ROUTINE WILL PROVIDE THE ADDRESS OF THE EIGHT * 07540000
* CHARACTER SYSTEM JOBNAME IN REGISTER 0 (TIOT) AND THE * 07550000
* ADDRESS OF THE EIGHT CHARACTER JES JOBID IN REGISTER 1. * 07560000
* * 07570000
* REGISTERS UPON ENTRY. * 07580000
* R0 = UNUSED * 07590000
* R1 = UNUSED * 07600000
* R15 = 8 * 07610000
* * 07620000
* REGISTERS UPON RETURN. * 07630000
* R0 = ADDRESS OF SYSTEM JOBNAME (TIOT) * 07640000
* R1 = ADDRESS OF JES JOBID * 07650000
* R15 = 0 * 07660000
* * 07670000
* INVALID CONTROL BLOCK STRUCTURE (JCT NOT FOUND) * 07680000
* R0 = UNPREDICTABLE * 07690000
* R1 = UNPREDICTABLE * 07700000
* R15 = 16 * 07710000
* * 07720000
*********************************************************************** 07730000
JESJOBID DS 0H JESJOBID ENTRY 07740000
USING JESJOBID,R6 BASE FOR SUBROUTINE 07750000
USING JCT,R10 ADDRESSABILITY ESTABLISHED IN $JCT 07760006
JCTGET GET JCT ADDRESS 07770000
L R0,TCBTIO SET R0=A(TIOT) 07780000
LA R1,JCTJOBID SET R1=A(JES JOB NUMBER) 07790000
SR R15,R15 SET R15=0, RETURN CODE 07800000
BR R14 RETURN TO SVC HANDLER 07810000
LTORG 07820000
DROP R6 DROP USE OF R6 BASE REGISTER 07830000
DROP R10 DROP USE OF R10 BASE REGISTER 07840000
EJECT 07850000
*********************************************************************** 07860000
* * 07870000
* THIS ROUTINE WILL PROVIDE THE ADDRESS OF THE JES INPUT * 07880000
* DEVICE IN REGISTER 1. * 07890000
* * 07900000
* REGISTERS UPON ENTRY. * 07910000
* R0 = UNUSED * 07920000
* R1 = UNUSED * 07930000
* R15 = 9 * 07940000
* * 07950000
* REGISTERS UPON RETURN. * 07960000
* REMOTE INPUT DEVICE. * 07970000
* R0 = UNCHANGED * 07980000
* R1 = ADDRESS OF JES INPUT DEVICE * 07990000
* R15 = 0 * 08000000
* NOT REMOTE INPUT DEVICE. * 08010000
* R0 = UNCHANGED * 08020000
* R1 = ADDRESS OF JES INPUT DEVICE * 08030000
* R15 = 4 * 08040000
* INVALID CONTROL BLOCK STRUCTURE (JCT NOT FOUND) * 08050000
* R0 = UNPREDICTABLE * 08060000
* R1 = UNPREDICTABLE * 08070000
* R15 = 16 * 08080000
* * 08090000
*********************************************************************** 08100000
JESINDEV DS 0H JESINDEV ENTRY 08110000
USING JESINDEV,R6 BASE FOR SUBROUTINE 08120000
USING JCT,R10 ADDRESSABILITY ESTABLISHED IN $JCT 08130006
JCTGET GET JCT ADDRESS 08140000
CLI JCTINDEV,C'R' CHECK FOR REMOTE INDEV 08150000
BNE JESIRT04 IF NOT, GO TO JESIRT04 08160000
CLI JCTINDEV+1,C'1' CHECK FOR REMOTE INDEV 08170000
BL JESIRT04 IF NOT, GO TO JESIRT04 08180000
CLI JCTINDEV+2,C'.' CHECK FOR REMOTE INDEV 08190000
BE JESIRT00 IF REMOTE, GO TO JESIRT00 08200000
CLI JCTINDEV+2,C'0' CHECK FOR REMOTE INDEV 08210000
BL JESIRT04 IF NOT, GO TO JESIRT04 08220000
CLI JCTINDEV+3,C'.' CHECK FOR REMOTE INDEV 08230000
BE JESIRT00 IF REMOTE, GO TO JESIRT00 08240000
CLI JCTINDEV+3,C'0' CHECK FOR REMOTE INDEV 08250000
BL JESIRT04 IF NOT, GO TO JESIRT04 08260000
JESIRT00 LA R1,JCTINDEV SET R1=A(JES INPUT DEVICE) 08270000
SR R15,R15 SET R15=0, RETURN CODE 08280000
BR R14 RETURN TO SVC HANDLER 08290000
JESIRT04 LA R1,JCTINDEV SET R1=A(JES INPUT DEVICE) 08300000
LA R15,4 SET R15=4, RETURN CODE 08310000
BR R14 RETURN TO SVC HANDLER 08320000
LTORG 08330000
DROP R6 08340000
DROP R10 08350000
EJECT 08360000
*********************************************************************** 08370000
* * 08380000
* THIS ROUTINE WILL ISSUE A FULL SCREEN TPUT TO BLANK OUT * 08390000
* THE ENTIRE SCREEN ON DISPLAY TERMINALS ONLY. ALSO, IF * 08400000
* THE TERMINAL IS A DISPLAY DEVICE, A TCLEARQ IS ISSUED * 08410000
* TO STRIP OFF THE 'RESHOW' (PA2) THAT IS STACKED BY ISPF. * 08420000
* * 08430000
* REGISTERS UPON ENTRY. * 08440000
* R0 = UNUSED * 08450000
* R1 = UNUSED * 08460000
* R15 = 10 * 08470000
* * 08480000
* REGISTERS UPON RETURN. * 08490000
* R0 = # LINES PER SCREEN * 08500000
* R1 = # CHARACTERS PER LINE * 08510000
* R15 = 0 * 08520000
* * 08530000
*********************************************************************** 08540000
CLEAR DS 0H JESINDEV ENTRY 08550000
USING CLEAR,R6 BASE FOR SUBROUTINE 08560000
GTSIZE , TEST FOR SCREEN TERMINAL 08570000
LTR R0,R0 BYPASS TPUT IF NOT 08580000
BZ CLEARE NOT A TUBE, IGNORE REQUEST 08590000
TPUT CLEARD,CLEARL,FULLSCR,WAIT,HOLD CLEAR THE TUBE 08600000
TCLEARQ INPUT RESET INPUT STACK 08610000
GTSIZE , INITIALIZED R0/R1 SIZES 08620000
CLEARE DS 0H JESINDEV ENTRY 08630000
SR R15,R15 SET R15=0, RETURN CODE 08640000
BR R14 RETURN TO SVC HANDLER 08650000
LTORG 08660000
CLEARD DC X'F1115D7E114040133CC75F003C4E7F003CD65F003C404000' 08670000
CLEARL EQU *-CLEARD LENGTH OF TPUT 08680000
LTORG 08690000
DROP R6 DROP USE OF R6 BASE REGISTER 08700000
EJECT 08710000
*********************************************************************** 08720000
* * 08730000
* THIS ROUTINE WILL CONVERT A CALENDAR DATE IN THE FORMAT * 08740000
* OF 0MMDDYYS TO THE CORRESPONDING JULIAN DATE IN THE * 08750000
* FORMAT OF 00YYDDDF, AND RETURN THE DAY OF WEEK OFFSET * 08760000
* IN THE FORMAT OF 0000000O. BOTH DATE FIELDS ARE IN * 08770000
* PACKED DECIMAL NOTATION AND THE DAY OF WEEK OFFSET IS * 08780000
* IN BINARY. CALENDAR DATE IS PASSED IN R0, DAY OF WEEK * 08790000
* OFFSET IS RETURNED IN R0, AND JULIAN DATE IS RETURNED * 08800000
* IN R1. * 08810000
* * 08820000
* REGISTERS UPON ENTRY. * 08830000
* R0 = CALENDAR DATE IN PACKED FORMAT 0MMDDYYS * 08840000
* R1 = UNUSED * 08850000
* R15 = 11 * 08860000
* * 08870000
* REGISTERS UPON RETURN. * 08880000
* DATE PASSED IN R0 IS VALID. * 08890000
* R0 = DAY OF WEEK OFFSET IN BINARY FORMAT (0=MONDAY) * 08900000
* R1 = JULIAN DATE IN PACKED FORMAT 00YYDDDF * 08910000
* R15 = 0 * 08920000
* DATE PASSED IN R0 IS INVALID. * 08930000
* R0 = UNCHANGED * 08940000
* R1 = UNCHANGED * 08950000
* R15 = 4 * 08960000
* * 08970000
*********************************************************************** 08980000
SPACE 1 08990000
CALJUL DS 0H CALJUL ENTRY 09000000
USING CALJUL,R6 BASE FOR SUBROUTINE 09010000
USING TWORK,R13 ESTABLISH ADDRESSABILITY 09020000
CALJ1000 DS 0H 09030000
LR R8,R0 SAVE R0 IN R8 09040000
LR R9,R1 SAVE R1 IN R9 09050000
LA R0,24 SET R0=24, GETMAIN LENGTH 09060000
GETMAIN R,LV=(0) GET SOME STORAGE 09070000
LR R13,R1 SET R13=A(TWORK) 09080000
ST R8,TW08L04 STORE CALENDAR DATE IN TWORK 09090000
TRT TW08L04,CTRTAB3 CHECK FOR VALID PACKED FORMAT 09100000
BC 12,CALJRT04 IF INVALID, GO TO CALJRT04 09110000
LA R1,X'80' SET R1=X'80', CONSTANT 09120000
NR R1,R2 CHECK FOR LAST BYTE VALID 09130000
BZ CALJRT04 IF INVALID, GO TO CALJRT04 09140000
CLI TW08L01,X'01' CHECK FOR XMM=(00M OR 01M) 09150000
BH CALJRT04 IF NOT, GO TO CALJRT04 09160000
UNPK TW12L06,TW08L04 UNPACK CALENDAR DATE AT 09170000
OI TW17L01,C'0' FORCE F SIGN 09180000
PACK TW00L08,TW12L02 PACK MM 09190000
CVB R3,TW00L08 SET R3=BINARY MM 09200000
LTR R3,R3 CHECK FOR MM=0 09210000
BZ CALJRT04 IF 0, GO TO CALJRT04 09220000
LA R15,12 SET R15=12, CONSTANT 09230000
CR R3,R15 CHECK FOR MM GT 12 09240000
BH CALJRT04 IF GT, GO TO CALJRT04 09250000
PACK TW00L08,TW14L02 PACK DD 09260000
CVB R4,TW00L08 SET R4=BINARY DD 09270000
LTR R4,R4 CHECK FOR DD=0 09280000
BZ CALJRT04 IF 0, GO TO CALJRT04 09290000
PACK TW00L08,TW16L02 PACK YY 09300000
CVB R5,TW00L08 SET R5=BINARY YY 09310000
LA R1,CDTABNLP SET R1=A(NON-LEAP YEAR TABLE) 09320000
CLC TW16L02,=CL2'00' CHECK FOR 1900 09330000
BE CALJ1100 IF 1900, NOT LEAP, GO TO CALJ1100 09340000
STC R5,TW00L01 SET TW00L01=BINARY YY 09350000
TM TW00L01,X'03' CHECK FOR NOT DIVISIBLE BY 4 09360000
BNZ CALJ1100 IF NOT, NOT LEAP, GO TO CALJ1100 09370000
LA R1,CDTABLP SET R1=A(LEAP YEAR TABLE) 09380000
CALJ1100 LA R15,0(R1,R3) SET R15=A(MAX DAYS IN MONTH) 09390000
CLM R4,1,0(R15) CHECK FOR VALID DD 09400000
BH CALJRT04 IF GT, INVALID, GO TO CALJRT04 09410000
PACK TW08L03,TW16L03 PACK YY INTO JULIAN FORMAT 09420000
SLL R3,1 SET R3=2*MM 09430000
LA R15,11(R1,R3) SET R15=A(N(DAYS IN PREC MOS))-2 09440000
ZAP TW10L02,0(2,R15) PACK DAYS INTO JULIAN FORMAT 09450000
CVD R4,TW00L08 CONVERT DD TO DECIMAL 09460000
AP TW10L02,TW00L08 ADD DD TO PRECEDING DAYS 09470000
OI TW11L01,X'0F' FORCE F SIGN 09480000
L R9,TW08L04 SET R9=PACKED JULIAN DATE 09490000
ZAP TW00L08,TW10L02 SET TW00L08=PACKED JULIAN DDDF 09500000
CVB R4,TW00L08 SET R4=BINARY JULIAN DDD 09510000
MVO TW00L08,TW09L01 SET TW00L08=PACKED JULIAN YYF 09520000
CVB R5,TW00L08 SET R5=BINARY JULIAN YY 09530000
LA R2,365 SET R2=365, MULTIPLIER 09540000
LR R11,R5 SET R11=YY 09550000
MR R10,R2 SET R11=365*YY 09560000
LTR R10,R5 SET R10=YY 09570000
BZ *+6 IF YY EQ 00, SKIP NEXT INSTRUCTION 09580000
BCTR R10,R0 SET R10=YY-1 09590000
SRL R10,2 SET R10=I((YY-1)/4) 09600000
AR R11,R10 SET R11=365*YY+I((YY-1)/4) 09610000
AR R11,R4 SET R11=365*YY+I((YY-1)/4)+DDD 09620000
BCTR R11,R0 SET R11=365*YY+I((YY-1)/4)+DDD-1 09630000
LA R2,7 SET R2=7, DIVISOR 09640000
SR R10,R10 SET R10=0, R11=DAYS-1 09650000
DR R10,R2 SET R10=R((DAYS-1)/7) 09660000
LR R8,R10 SET R8=DAY OF WEEK OFFSET 09670000
CALJRT00 SR R10,R10 SET R10=0, RETURN CODE 09680000
B CALJRTXX GO TO CALJRTXX 09690000
CALJRT04 LA R10,4 SET R10=4, RETURN CODE 09700000
CALJRTXX LA R0,24 SET R0=24, L'GETMAIN AREA 09710000
LA R1,TWORK SET R1=A(GETMAIN AREA) 09720000
FREEMAIN R,LV=(0),A=(1) FREE GOTTEN STORAGE 09730000
LR R0,R8 RESTORE NEW/ORIGINAL R0 FROM R8 09740000
LR R1,R9 RESTORE NEW/ORIGINAL R1 FROM R9 09750000
LR R15,R10 SET R15=RETURN CODE 09760000
BR R14 RETURN TO SVC HANDLER 09770000
SPACE 1 09780000
DROP R6 DROP USE OF R6 BASE REGISTER 09790000
DROP R13 DROP USE OF R13 BASE REGISTER 09800000
EJECT 09810000
*********************************************************************** 09820000
* * 09830000
* THIS ROUTINE WILL CONVERT A JULIAN DATE IN THE FORMAT * 09840000
* OF 00YYDDDS TO THE CORRESPONDING CALENDAR DATE IN THE * 09850000
* FORMAT OF 0MMDDYYF, AND RETURN THE DAY OF WEEK OFFSET * 09860000
* IN THE FORMAT OF 0000000O. BOTH DATE FIELDS ARE IN * 09870000
* PACKED DECIMAL NOTATION AND THE DAY OF WEEK OFFSET IS * 09880000
* IN BINARY. JULIAN DATE IS PASSED IN R0, DAY OF WEEK * 09890000
* OFFSET IS RETURNED IN R0, AND CALENDAR DATE IS RETURNED * 09900000
* IN R1. * 09910000
* * 09920000
* REGISTERS UPON ENTRY. * 09930000
* R0 = JULIAN DATE IN PACKED FORMAT 00YYDDDS * 09940000
* R1 = UNUSED * 09950000
* R15 = 12 * 09960000
* * 09970000
* REGISTERS UPON RETURN. * 09980000
* DATE PASSED IN R0 IS VALID. * 09990000
* R0 = DAY OF WEEK OFFSET IN BINARY FORMAT (0=MONDAY) * 10000000
* R1 = CALENDAR DATE IN PACKED FORMAT 0MMDDYYF * 10010000
* R15 = 0 * 10020000
* DATE PASSED IN R0 IS INVALID. * 10030000
* R0 = UNCHANGED * 10040000
* R1 = UNCHANGED * 10050000
* R15 = 4 * 10060000
* * 10070000
*********************************************************************** 10080000
SPACE 1 10090000
JULCAL DS 0H JULCAL ENTRY 10100000
USING JULCAL,R6 BASE FOR SUBROUTINE 10110000
USING TWORK,R13 ESTABLISH ADDRESSABILITY 10120000
JULC1000 DS 0H 10130000
LR R8,R0 SAVE R0 IN R8 10140000
LR R9,R1 SAVE R1 IN R9 10150000
LA R0,24 SET R0=24, GETMAIN LENGTH 10160000
GETMAIN R,LV=(0) GET SOME STORAGE 10170000
LR R13,R1 SET R13=A(TWORK) 10180000
ST R8,TW08L04 STORE CALENDAR DATE IN TWORK 10190000
TRT TW08L04,CTRTAB3 CHECK FOR VALID PACKED FORMAT 10200000
BC 12,JULCRT04 IF INVALID, GO TO JULCRT04 10210000
LA R1,X'80' SET R1=X'80', CONSTANT 10220000
NR R1,R2 CHECK FOR LAST BYTE VALID 10230000
BZ JULCRT04 IF INVALID, GO TO JULCRT04 10240000
CLI TW08L01,X'00' CHECK FOR XXYY=00YY 10250000
BNE JULCRT04 IF NOT, GO TO JULCRT04 10260000
ZAP TW00L08,TW10L02 CHECK FOR DDDS=000S 10270000
BZ JULCRT04 IF 0, GO TO JULCRT04 10280000
OI TW11L01,X'0F' FORCE F SIGN ON JULIAN DATE 10290000
LA R15,CDTABNLP+13 SET R15=A(NON-LEAP YEAR TABLE) 10300000
CLI TW09L01,X'00' CHECK FOR 1900 10310000
BE JULC1100 IF 1900, NOT LEAP, GO TO JULC1100 10320000
TM TW09L01,X'03' CHECK FOR YY DIVISIBLE BY 4 10330000
BNZ JULC1100 IF NOT, GO TO JULC1100 10340000
LA R15,CDTABLP+13 SET R15=A(LEAP YEAR TABLE) 10350000
JULC1100 LA R0,1 SET R0=1, BXLE INCREMENT 10360000
LA R1,12 SET R1=12, BXLE LIMIT 10370000
LR R2,R0 SET R2=1, BXLE START 10380000
JULC1110 CP TW10L02,2(2,R15) CHECK FOR DDD LE TABLE ENTRY 10390000
BNH JULC1200 IF LE, GO TO JULC1200 10400000
LA R15,2(R15) SET R15=A(NEXT TABLE ENTRY) 10410000
BXLE R2,R0,JULC1110 CONTINUE AT JULC1110 10420000
B JULCRT04 INVALID DDD, GO TO JULCRT04 10430000
JULC1200 CVD R2,TW00L08 CONVERT R2 MM TO DECIMAL 10440000
UNPK TW12L02,TW00L08 UNPACK MM 10450000
SP TW10L02,0(2,R15) SET TW10L02=DD 10460000
UNPK TW14L02,TW10L02 UNPACK DD 10470000
UNPK TW16L03,TW09L02 UNPACK YY 10480000
PACK TW08L04,TW12L06 PACK MMDDYY 10490000
L R9,TW08L04 SET R9=PACKED CALENDAR DATE 10500000
ST R8,TW08L04 SET TW08L04=PACKED JULIAN DATE 10510000
ZAP TW00L08,TW10L02 SET TW00L08=PACKED JULIAN DDDF 10520000
CVB R4,TW00L08 SET R4=BINARY JULIAN DDD 10530000
MVO TW00L08,TW09L01 SET TW00L08=PACKED JULIAN YYF 10540000
CVB R5,TW00L08 SET R5=BINARY JULIAN YY 10550000
LA R2,365 SET R2=365, MULTIPLIER 10560000
LR R11,R5 SET R11=YY 10570000
MR R10,R2 SET R11=365*YY 10580000
LTR R10,R5 SET R10=YY 10590000
BZ *+6 IF YY EQ 00, SKIP NEXT INSTRUCTION 10600000
BCTR R10,R0 SET R10=YY-1 10610000
SRL R10,2 SET R10=I((YY-1)/4) 10620000
AR R11,R10 SET R11=365*YY+I((YY-1)/4) 10630000
AR R11,R4 SET R11=365*YY+I((YY-1)/4)+DDD 10640000
BCTR R11,R0 SET R11=365*YY+I((YY-1)/4)+DDD-1 10650000
LA R2,7 SET R2=7, DIVISOR 10660000
SR R10,R10 SET R10=0, R11=DAYS-1 10670000
DR R10,R2 SET R10=R((DAYS-1)/7) 10680000
LR R8,R10 SET R8=DAY OF WEEK OFFSET 10690000
JULCRT00 SR R10,R10 SET R10=0, RETURN CODE 10700000
B JULCRTXX GO TO JULCRTXX 10710000
JULCRT04 LA R10,4 SET R10=4, RETURN CODE 10720000
JULCRTXX LA R0,24 SET R0=24, L'GETMAIN AREA 10730000
LA R1,TWORK SET R1=A(GETMAIN AREA) 10740000
FREEMAIN R,LV=(0),A=(1) FREE GOTTEN STORAGE 10750000
LR R0,R8 RESTORE NEW/ORIGINAL R0 FROM R8 10760000
LR R1,R9 RESTORE NEW/ORIGINAL R1 FROM R9 10770000
LR R15,R10 SET R15=RETURN CODE 10780000
BR R14 RETURN TO SVC HANDLER 10790000
SPACE 1 10800000
DROP R6 DROP USE OF R6 BASE REGISTER 10810000
DROP R13 DROP USE OF R13 BASE REGISTER 10820000
EJECT 10830000
*********************************************************************** 10840000
* * 10850000
* THIS ROUTINE WILL COMPUTE THE DIFFERENCE IN DAYS * 10860000
* BETWEEN TWO JULIAN DATES. THE DATES ARE PASSED IN R0 * 10870000
* AND R1 AND ARE IN PACKED DECIMAL NOTATION WITH FORMAT * 10880000
* OF 00YYDDDS. THE DIFFERENCE IS A BINARY NUMBER * 10890000
* RETURNED IN R1. * 10900000
* * 10910000
* REGISTERS UPON ENTRY. * 10920000
* R0 = JULIAN DATE(1) IN PACKED FORMAT 00YYDDDS * 10930000
* R0 = JULIAN DATE(2) IN PACKED FORMAT 00YYDDDS * 10940000
* R15 = 13 * 10950000
* * 10960000
* REGISTERS UPON RETURN. * 10970000
* DATES PASSED IN R0 AND R1 ARE VALID. * 10980000
* R0 = UNCHANGED * 10990000
* R1 = BINARY NUMBER OF DAYS DIFFERENCE * 11000000
* R15 = 0 * 11010000
* DATE(S) INVALID OR DATE1 GT DATE2. * 11020000
* R0 = UNCHANGED * 11030000
* R1 = UNCHANGED * 11040000
* R15 = 4 - DATE(1) INVALID * 11050000
* 8 - DATE(2) INVALID * 11060000
* 12 - DATE(1) AND DATE(2) BOTH INVALID * 11070000
* 16 - DATE(1) GT DATE(2) * 11080000
* * 11090000
*********************************************************************** 11100000
SPACE 1 11110000
JULDIF DS 0H JULDIF ENTRY 11120000
USING JULDIF,R6 BASE FOR SUBROUTINE 11130000
USING TWORK,R13 ESTABLISH ADDRESSABILITY 11140000
JULD1000 DS 0H 11150000
LR R8,R0 SAVE R0 IN R8 11160000
LR R9,R1 SAVE R1 IN R9 11170000
LA R0,16 SET R0=16, GETMAIN LENGTH 11180000
GETMAIN R,LV=(0) GET SOME STORAGE 11190000
LR R13,R1 SET R13=A(TWORK) 11200000
LR R0,R8 SET R0=DATE(1) 11210000
BAL R11,JULD8000 LINK TO VALIDATE/COMPUTE ROUTINE 11220000
LR R3,R1 SET R3=DAYS IN CENTURY, DATE(1) 11230000
LR R10,R15 SET R10=RETURN CODE 11240000
LR R0,R9 SET R0=DATE(2) 11250000
BAL R11,JULD8000 LINK TO VALIDATE/COMPUTE ROUTINE 11260000
LR R4,R1 SET R4=DAYS IN CENTURY, DATE(2) 11270000
SLL R15,1 SET R15=RETURN CODE*2 11280000
OR R10,R15 OR SECOND RC INTO R10 11290000
BNZ JULDRTXX IF EITHER NE 0, GO TO JULDRTXX 11300000
SR R4,R3 SET R4=DAYS DIFFERENCE 11310000
BNM JULDRT00 IF NOT MINUS, GO TO JULDRT00 11320000
LA R10,16 SET R10=16, RETURN CODE 11330000
B JULDRTXX GO TO JULDRTXX 11340000
JULD8000 ST R0,TW08L04 STORE CALENDAR DATE IN TWORK 11350000
TRT TW08L04,CTRTAB3 CHECK FOR VALID PACKED FORMAT 11360000
BC 12,JULD8910 IF INVALID, GO TO JULD8910 11370000
LA R1,X'80' SET R1=X'80', CONSTANT 11380000
NR R1,R2 CHECK FOR LAST BYTE VALID 11390000
BZ JULD8910 IF INVALID, GO TO JULD8910 11400000
CLI TW08L01,X'00' CHECK FOR VALID 00YY 11410000
BNE JULD8910 IF INVALID, GO TO JULD8910 11420000
OI TW11L01,X'0F' FORCE F SIGN ON DATE 11430000
LA R15,CDTABNLP+13+12*2 SET R15=A(DAYS/NON-LEAP YEAR) 11440000
CLI TW09L01,X'00' CHECK FOR 1900 11450000
BE JULD8100 IF 1900 GO TO JUDL8100 11460000
TM TW09L01,X'03' CHECK FOR YY DIVISIBLE BY 4 11470000
BNZ JULD8100 IF NOT, GO TO JUDL8100 11480000
LA R15,CDTABLP+13+12*2 SET R15=A(DAYS/LEAP YEAR) 11490000
JULD8100 CP TW10L02,0(2,R15) CHECK DDD GT MAX 11500000
BH JULD8910 IF GT, INVALID, GO TO JULD8910 11510000
SR R2,R2 SET R2=0, N(LEAP YEARS) 11520000
MVI TW07L01,X'0F' MOVE F SIGN TO TW00L08 11530000
MVO TW00L08,TW09L01 MOVE YY TO 0000000000000YYF 11540000
CVB R1,TW00L08 SET R1=BINARY YY 11550000
CLI TW09L01,X'00' CHECK FOR 1900 11560000
BE JULD8200 IF 1900, 0 LEAPS, GO TO JULD8200 11570000
LR R2,R1 SET R2=BINARY YY 11580000
BCTR R2,R0 SET R2=YY-1 11590000
SRL R2,2 SET R2=(YY-1)/4, N(LEAP YEARS) 11600000
JULD8200 ZAP TW00L08,TW10L02 ZAP DDDF TO 000000000000DDDF 11610000
CVB R0,TW00L08 SET R0=BINARY DDD 11620000
AR R2,R0 SET R2=LEAPS+DDD 11630000
LA R15,365 SET R15=365, CONSTANT 11640000
MR R0,R15 SET R1=YY*365 11650000
AR R1,R2 SET R1=YY*365+DDD+LEAPS 11660000
JULD8900 SR R15,R15 SET R15=0, RETURN CODE 11670000
B JULD8990 GO TO JULD8990 11680000
JULD8910 LA R15,4 SET R15=4, RETURN CODE 11690000
JULD8990 BR R11 RETURN TO INVOKER 11700000
JULDRT00 LR R9,R4 SET R9=BINARY DAYS DIFFERENCE 11710000
SR R10,R10 SET R10=0, RETURN CODE 11720000
JULDRTXX LA R0,16 SET R0=16, L'GETMAIN AREA 11730000
LA R1,TWORK SET R1=A(GETMAIN AREA) 11740000
FREEMAIN R,LV=(0),A=(1) FREE GOTTEN STORAGE 11750000
LR R0,R8 RESTORE ORIGINAL R0 FROM R8 11760000
LR R1,R9 RESTORE ORIGINAL R1 FROM R9 11770000
LR R15,R10 SET R15=RETURN CODE 11780000
BR R14 RETURN TO SVC HANDLER 11790000
SPACE 1 11800000
CTRTAB3 DC 10XL16'00000000000000000000010180800180',96XL1'01' 11810000
CDTABLP DC AL1(00,31,29,31,30,31,30,31,31,30,31,30,31) 11820000
DC PL2'000',PL2'031',PL2'060',PL2'091',PL2'121',PL2'152' 11830000
DC PL2'182',PL2'213',PL2'244',PL2'274',PL2'305',PL2'335' 11840000
DC PL2'366' 11850000
CDTABNLP DC AL1(00,31,28,31,30,31,30,31,31,30,31,30,31) 11860000
DC PL2'000',PL2'031',PL2'059',PL2'090',PL2'120',PL2'151' 11870000
DC PL2'181',PL2'212',PL2'243',PL2'273',PL2'304',PL2'334' 11880000
DC PL2'365' 11890000
SPACE 1 11900000
TWORK DSECT 11910000
TW00L19 DS 0CL19 11920000
TW00L08 DS 0CL8 11930000
TW00L04 DS 0CL4 11940000
TW00L02 DS 0CL2 11950000
TW00L01 DS CL1 11960000
TW01L19 DS 0CL19,CL1 11970000
TW02L01 DS CL1 11980000
TW03L02 DS 0CL2,CL1 11990000
TW04L04 DS 0CL4,CL1 12000000
TW05L01 DS CL1 12010000
TW06L02 DS 0CL2,CL1 12020000
TW07L01 DS CL1 12030000
TW08L04 DS 0CL4 12040000
TW08L03 DS 0CL3 12050000
TW08L01 DS CL1 12060000
TW09L02 DS 0CL2 12070000
TW09L01 DS CL1 12080000
TW10L02 DS 0CL2,CL1 12090000
TW11L01 DS CL1 12100000
TW12L06 DS 0CL6 12110000
TW12L02 DS CL2 12120000
TW14L02 DS 0CL2 12130000
TW14L01 DS CL1 12140000
TW15L02 DS 0CL2,CL1 12150000
TW16L04 DS 0CL4 12160000
TW16L03 DS 0CL3 12170000
TW16L02 DS 0CL2,CL1 12180000
TW17L01 DS CL1 12190000
MVSGPSVC CSECT 12200000
DROP R6 DROP USE OF R6 BASE REGISTER 12210000
DROP R13 DROP USE OF R13 BASE REGISTER 12220000
EJECT 12230000
*********************************************************************** 12240000
* * 12250000
* * 12260000
XACF DS 0H 12270000
USING XACF,R6 BASE FOR SUBROUTINE 12280000
USING RBBASIC,R5 ESTABLISH ADDRESSABILITY 12290000
USING ASXB,R8 ESTABLISH ADDRESSABILITY 12300000
USING ACEE,R10 ESTABLISH ADDRESSABILITY 12310000
USING CDENTRY,R11 ESTABLISH ADDRESSABILITY 12320000
L R8,ASCBASXB GET ASXB FROM ASCB 12330000
ICM R10,15,ASXBSENV GET CALLERS ACEE 12340000
BZR R14 RETURN IF NO ACEE 12350000
CLC ACEEACEE,=CL4'ACEE' IS IT REALLY AN ACEE? 12360000
BNER R14 RETURN IF NO ACEE 12370000
TM ACEEFLG1,ACEERACF IS CALLER RACF DEFINED? 12380000
BZR R14 NO, IGNORE REQUEST 12390000
L R5,RBLINK GET CALLERS RB ADDRESS 12400000
L R11,RBCDE GET CALLERS CDE 12410000
CLC CDNAME(5),=CL5'CMNER' CALLER RACF/SPF INTERFACE? 12420000
BNER R14 NO, IGNORE REQUEST 12430000
LR R8,R0 COPY PARM REG 12440000
LTR R9,R1 COPY PARM REG 12450000
BZ XACFEND ZERO, IGNORE REQUEST 12460000
C R8,CDENTPT IS THIS REQUEST FOR SPECIAL? 12470000
BNE XACFBY NO, NORMAL CALL 12480000
ICM R7,8,ACEEFLG1 SAVE ORIGINAL ACEE FLAG 12490000
* OI ACEEFLG1,ACEESPEC TEMPORARILY ADD SPECIAL 12500000
XACFBY DS 0H 12510000
SVC 132 INVOKE RACF SVC FOR CALLER 12520000
C R8,CDENTPT WAS THIS REQUEST FOR SPECIAL? 12530000
BNE XACFEND NO, NORMAL CALL 12540000
* STCM R7,8,ACEEFLG1 RESTORE ORIGINAL ACEE FLAG 12550000
L R8,=F'-1' RESET KEY 12560000
XACFEND DS 0H 12570000
LR R0,R8 RESTORE PARM REG 12580000
LR R1,R9 RESTORE PARM REG 12590000
DROP R11 DROP USING REG 12600000
DROP R10 DROP USING REG 12610000
DROP R8 DROP USING REG 12620000
DROP R5 DROP USING REG 12630000
BR R14 AND RETURN WITH R15 = RETCODE 12640000
LTORG 12650000
DROP R6 DROP USE OF R6 BASE REGISTER 12660000
* 12670000
WTO DSECT 12680000
WTOLNMCS DS CL4 12690000
WTOMSG DS 0CL252 12700000
MVSGPSVC CSECT 12710000
EJECT 12720000
*********************************************************************** 12730000
* * 12740000
* END OF MVS GP SVC SUBROUTINES * 12750000
* * 12760000
* DSECTS AND EQUATES FOR SYSTEM AREAS FOLLOW * 12770000
* * 12780000
*********************************************************************** 12790000
PRINT NOGEN 12800000
SPACE 1 12810008
CVT DSECT=YES COMMUNICATION VECTOR TABLE 12820000
SPACE 3 12830000
IEFJESCT TYPE=DSECT JOB ENTRY SUBSYSTEM COMMUNICATION 12840000
SPACE 3 12850000
IEFJSCVT SUBSYSTEM COMMUNICATION VECTOR TBL 12860000
SPACE 3 12870000
IEFJSSVT JES2 SSVT 12880005
SPACE 3 12890005
IHAASCB DSECT=YES ADDRESS SPACE CONTROL BLOCK 12900000
SPACE 3 12910000
IHAASVT DSECT=YES ADDRESS SPACE VECTOR TABLE 12920000
SPACE 3 12930000
IKJTCB DSECT=YES TASK CONTROL BLOCK 12940000
SPACE 3 12950000
IEZJSCB JOB/STEP CONTROL BLOCK 12960000
SPACE 3 12970000
IKJPSCB PROTECT STEP CONTROL BLOCK 12980000
SPACE 3 12990000
TIOT DSECT TASK INPUT/OUTPUT TABLE 13000000
IEFTIOT1 13010000
SPACE 3 13020000
$XECB HASP EXTENED ECB 13030000
SPACE 3 13040000
UCBDSECT DSECT UNIT CONTROL BLOCK 13050000
IEFUCBOB PREFIX=NO 13060000
SPACE 3 13070000
$SCAT HASP SYSOUT CLASS ATTRIBUTE TABLE 13080000
SPACE 3 13090000
** $SVT HASP SUBSYSTEM VECTOR TABLE 13100005
** SPACE 3 13110005
$HASB HOLY ALLMIGHTY SMOKES BLOCK 13120006
SPACE 3 13130003
$SJB HASP SUBSYSTEM JOB BLOCK 13140003
SPACE 3 13150000
$BUFFER HASP BUFFER 13160000
SPACE 3 13170000
$HCCT HOLY COW CONTROL TABLE 13180001
SPACE 3 13190000
$JCT HASP JOB CONTROL TABLE 13200001
SPACE 3 13210001
$TQE TEQUILLA ELEMENT. REQ'D BY HCCT 13220007
SPACE 3 13230007
$HFAME HALL OF FAME. REQ'D BY HCCT 13240008
SPACE 3 13250007
$HASPEQU JES2 GLOBAL EQUATES 13260007
SPACE 3 13270007
IFGRPL AM=VSAM VSAM RPL 13280005
SPACE 3 13290005
IHAASXB ADDRSSS SPACE EXTENSION BLOCK 13300004
SPACE 3 13310004
IHAACEE ACESSOR ENVIRONMENT ELEMENT 13320000
SPACE 3 13330000
IHARB OS/VS REQUEST BLOCK 13340000
SPACE 3 13350000
IHACDE CONTENTS DIRECTORY ENTRY 13360000
SPACE 3 13370001
IHAPSA LOW CORE ... 13380001
END 13390000
---------------------------------------------------------------------- For IBM-MAIN subscribe / signoff / archive access instructions, send email to [email protected] with the message: INFO IBM-MAIN
