Re-entrant date conversion routines

TITLE 'RE-ENTRANT GREGORIAN(YYYMMDDS)->JULIAN(0YYYDDDS)DATE' *---------------------------------------------------------------------* * CALL GREGJUL,(GDATE,JDATE) 1020710C->0102191C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR DATE. *---------------------------------------------------------------------* SPACE 2 GREGJUL CSECT , 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 4,5,0(1) LOAD CALLER INPUT/OUTPUT PARMS. UNPK GREGDT,0(4,4) SAVE/UNPACK INPUT GREG DATE. PACK DWORK,GREGYY CVB 4,DWORK R4 NOW 0000YYY. LA 2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365) LTR 3,4 Q,YEAR ZERO(1900)? BZ GREG200 Y,365 DAYS CORRECT. N 3,=A(3) Q,LEAP YEAR(366 DAY)? BNZ GREG200 N,MUST BE 365 DAY YEAR. LA 2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366) GREG200 DS 0H MH 4,=Y(1000) R4/FROM 0000YYY TO 0YYY000. PACK DWORK,GREGMM CVB 3,DWORK R3 NOW 00000MM. LTR 3,3 Q,POSITIVE(VALID) GREG-MONTH? BNP GREG300 N,EXIT,INVALID GREG MONTH. CH 3,=Y(12) Q,GREG-MONTH > 12? BH GREG300 Y,EXIT,INVALID GREG MONTH. BCTR 3,0 R3 NOW 0-11. AR 3,3 R3 NOW 0-22. AR 3,2 R3 NOW CORRECT MONTH ENTRY. PACK DWORK,GREGDD CVB 2,DWORK R2 NOW 00000DD. LTR 2,2 Q,POSITIVE(VALID) GREG-DAY? BNP GREG300 N,EXIT,INVALID GREG-DAY. AH 2,0(,3) GREGDD PLUS PREV MONTHS DAYS. CH 2,2(,3) Q,GREGDD > END OF MONTH? BH GREG300 Y,EXIT, INVALID GREG-DAY. AR 2,4 R2=0YYYDDD=0YYY000+0000DDD. CVD 2,DWORK DWORK NOW 000000000YYYDDDS. MVC 0(4,5),JDATE MOVE JDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. GREG300 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * SAVREGS DSECT DS 0D,18A CALLER SAVEREGS. DWORK DS 0D,4X JDATE DS PL4 0YYYDDDS (OUTPUT JULIAN DATE) GREGDT DS 0CL7 YYYMMDD (INPUT GREGORIAN DATE) GREGYY DS CL3 YYY GREGMM DS CL2 MM GREGDD DS CL2 DD * END TITLE 'RE-ENTRANT JULIAN(0YYYDDDS)->GREGORIAN(YYYMMDDS)DATE' *---------------------------------------------------------------------* * CALL JULGREG,(JDATE,GDATE) 0100366C->1001231C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR DATE. *---------------------------------------------------------------------* SPACE 2 JULGREG CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 4,5,0(1) LOAD CALLER INPUT/OUTPUT PARMS. UNPK JULDTE,0(4,4) UNPACK INPUT JULIAN DATE. PACK DWORK,JULYYY CVB 3,DWORK R3 NOW 0000YYY. LA 2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365) LTR 1,3 Q,YEAR ZERO(1900)? BZ JUL200 Y,1900 NOT A LEAP YEAR. N 1,=A(3) Q,LEAP YEAR(366 DAYS)? BNZ JUL200 N,365 DAY YEAR CORRECT. LA 2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366) JUL200 DS 0H PACK DWORK,JULDDD CVB 4,DWORK R4 NOW 0000DDD. CH 4,24(,2) Q,JULIAN DAY > EOY(365/366)? BH JUL400 Y,EXIT, ERROR JULIAN DAY. LTR 1,4 LOAD/TEST JULIAN DAY. BNP JUL400 EXIT, ERROR JULIAN DAY. SRL 1,5 DIV BY 32; R1 NOW 0-11. LR 0,1 R0 NOW 0-11. AR 0,0 R0 NOW 0-22. AR 2,0 R2=CORRECT TABLE ENTRY, MAYBE. LA 1,1(,1) R1=CORRECT MONTH, MAYBE. CH 4,2(,2) Q,JULIAN DAY > NEXT ENTRY. BNH JUL300 N,R1/R2 CORRECT MONTH/ENTRY. LA 1,1(,1) R1 NOW CORRECT MONTH(1-12). LA 2,2(,2) R2 NOW CORRECT ENTRY. JUL300 DS 0H SH 4,0(,2) R4 NOW CORRECT GREG DAY. MH 1,=Y(100) R1/FROM 00000MM TO 000MM00. AR 1,4 R1=000MMDD = 000MM00 + 00000DD. MH 3,=Y(10000) R3 FROM 0000YYY TO YYY0000. AR 3,1 R3=YYYMMDD = YYY0000 + 000MMDD. CVD 3,DWORK DWORK NOW 00000000YYYMMDDC. MVC 0(4,5),GDATE MOVE GDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. JUL400 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * SAVREGS DSECT DS 0D,18A USER SAVEREGS. DWORK DS 0D,4X GDATE DS PL4 YYYMMDDS JULDTE DS 0CL6 YYYDDD JULYYY DS CL3 YYY JULDDD DS CL3 DDD * END TITLE 'RE-ENTRANT PERPETUAL(DDDDDS)DATE->GREGORIAN(YYYMMDDS)' *---------------------------------------------------------------------* * CALL PERPGREG,(PDATE,GDATE) 36525C=>1001231C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR INPUT DATE. *---------------------------------------------------------------------* SPACE 2 PERPGREG CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 4,5,0(1) LOAD CALLER INPUT/OUTPUT PARMS. ZAP DWORK,0(3,4) MOVE/TEST INPUT PERP-DATE. BNP PERP500 EXIT, INVALID INPUT PERP-DATE. CVB 4,DWORK R4 NOW BINARY PERPETUAL DATE. LR 3,4 R3=R4 XR 2,2 NEEDED FOR NEXT INSTR. D 2,=A(365) R3 PROBABLY GOOD WORK YEAR. LR 1,3 R1=R3 SRL 1,2 R1 NUMBER OF LEAP YEAR DAYS. CR 1,2 Q,LEAP YEAR DAYS < REMAINDER? BL PERP200 Y,R3 GOOD WORK YEAR. BCTR 3,0 N,R3 NOW GOOD WORK YEAR. PERP200 DS 0H LR 2,3 NEEDED FOR LEAP YEAR DAYS CALC. LR 1,3 NEEDED BY NEXT INSTR(MH). M 0,=A(365) R1 NOW DAYS W/O LEAP YEAR DAYS. SRL 2,2 R2 NOW CORRECT LEAP YEAR DAYS. AR 2,1 R2 NOW DAYS IN PREV-YEARS. SR 4,2 R4 NOW CURRENT YEAR DAYS. LA 3,1(,3) R3 NOW CURRENT OUTPUT GREG-YEAR. LA 0,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365) LR 2,3 NEEDED FOR YEAR YEAR TEST. N 2,=A(3) Q,A LEAP YEAR? BNZ PERP300 N,ASSUMPTION CORRECT. LA 0,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366) PERP300 DS 0H LR 2,4 MOVE DAYS IN CURRENT YEAR. SRL 2,5 DIVIDE BY 32; R2 NOW 0-11. LR 1,2 R1 NOW 0-11. AR 1,1 R1 NOW 0-22. AR 1,0 R1 MAYBE CORRECT MONTH ENTRY. LA 2,1(,2) R2 MAYBE CORRECT MONTH(1-12). CH 4,2(,1) Q,CORRECT MONTH ENTRY? BNH PERP400 Y,SKIP ADJUSTMENT. LA 1,2(,1) R1 NOW CORRECT MONTH(1-12). LA 2,1(,2) R2 NOW CORRECT GREG-MONTH. PERP400 DS 0H SH 4,0(,1) R4 NOW OUTPUT GREG DAY(00000DD). MH 3,=Y(10000) R3/FROM 0000YYY TO YYY0000. MH 2,=Y(100) R2/FROM 00000MM TO 000MM00. AR 2,3 R2 NOW YYYMM00. AR 2,4 R2 NOW YYYMMDD. CVD 2,DWORK DWORK NOW 00000000YYYMMDDS. MVC 0(4,5),GDATE MOVE GDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. PERP500 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * SAVREGS DSECT DS 0D,18A USER SAVEREGS. DWORK DS 0D,4X GDATE DS PL4 YYYMMDDS * END TITLE 'RE-ENTRANT GREGORIAN(YYYMMDDS)->PERPETUAL(DDDDDS)DATE' *---------------------------------------------------------------------* * CALL GREGPERP,(GDATE,PDATE) 1001231C->36525C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR DATE. *---------------------------------------------------------------------* SPACE 2 GREGPERP CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 4,5,0(1) LOAD CALLER INPUT/OUTPUT PARMS. UNPK GREGDT,0(4,4) SAVE/UNPACK INPUT GREG-DATE. PACK DWORK,GREGYY PACK INPUT GREG YEAR. CVB 4,DWORK R4 NOW 00000YYY. LTR 3,4 Q,YEAR ZERO(1900)? BZ GREG300 Y,EXIT; INVALID GREG-YEAR. LA 2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365) N 3,=A(3) Q,A LEAP YEAR(366 DAYS)? BNZ GREG200 N,MUST BE 365 DAY YEAR. LA 2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366) GREG200 DS 0H PACK DWORK,GREGMM PACK INPUT GREGDATE MONTH. CVB 3,DWORK R3 NOW BINARY GREG MONTH. LTR 3,3 Q,POSITIVE GREG MONTH? BNP GREG300 N,EXIT; INVALID INPUT GREGDATE. CH 3,=Y(12) Q,INPUT GREGDATE MONTH > 12 ? BH GREG300 Y,EXIT; INVALID GREGDATE MONTH. BCTR 3,0 R3 NOW 0-11. AR 3,3 R3 NOW 0-22. AR 3,2 R3 NOW CORRECT MONTH-TBL ENTRY. PACK DWORK,GREGDD PACK INPUT GREGDATE DAY. CVB 2,DWORK LTR 2,2 Q,POSITIVE INPUT GREG DAY? BNP GREG300 N,EXIT; INVALID INPUT GREG DAY. AH 2,0(,3) PREV MONTH DAYS TO GREG DAY. CH 2,2(,3) Q,GREG DAY > END OF MONTH ? BH GREG300 Y,EXIT; INVALID GREG DAY. BCTR 4,0 DECREMENT BY 1 INPUT GREG YEAR. LR 3,4 R3=R4. SRL 3,2 R3 NOW LEAP YEAR DAYS. MH 4,=Y(365) R4 DAYS IN PREV YRS LESS LEAP. AR 4,3 R4 NOW DAYS IN PREV YEARS. AR 4,2 R4 NOW BINARY PERPETUAL DATE. CVD 4,DWORK DWORK NOW 0000000000DDDDDS. MVC 0(3,5),PDATE MOVE PDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. GREG300 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * SAVREGS DSECT DS 0D,18A USER SAVEREGS. DWORK DS 0D,5X PDATE DS PL3 DDDDDS GREGDT DS 0CL7 YYYMMDD GREGYY DS CL3 YYY GREGMM DS CL2 MM GREGDD DS CL2 DD END TITLE 'RE-ENTRANT PERPETUAL(DDDDDS) TO JULIAN(0YYYDDDS)DATE' *---------------------------------------------------------------------* * CALL PERPJUL,(PDATE,JDATE) 36525C->0100366C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR DATE. *---------------------------------------------------------------------* SPACE 2 PERPJUL CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 4,5,0(1) LOAD CALLER INPUT/OUTPUT ADDRS. ZAP DWORK,0(3,4) MOVE/TEST INPUT PERPETUAL DATE. BNP PERP300 EXIT, BAD INPUT PERPETUAL DATE. CVB 4,DWORK R4 NOW BINARY PERPETUAL DATE. LR 3,4 R3=R4. XR 2,2 NEEDED FOR NEXT INSTR. D 2,=A(365) R3 NOW PROBABLY GOOD WORK YEAR. LR 1,3 R1=R3. SRL 1,2 DIV BY 4; R1 NOW LEAP YEAR DAYS. CR 1,2 Q,LEAP YEAR DAYS < REMAINDER? BL PERP200 Y,R3 GOOD WORK YEAR. BCTR 3,0 N,R3 NOW GOOD WORK YEAR. PERP200 DS 0H LR 2,3 R2=R3. LR 1,3 R1=R3. M 0,=A(365) R1=PREV YRS DAYS,W/O LEAP DAYS. SRL 2,2 R2 NOW PREV LEAP YEAR DAYS. AR 2,1 R2 NOW PREV YEARS DAYS. SR 4,2 R4 NOW DAYS IN CURRENT YEAR. LA 3,1(,3) R3 NOW CORRECT OUTPUT JUL-YEAR. MH 3,=Y(1000) R3 FROM 0000YYY TO 0YYY000. AR 3,4 R3 NOW 0YYYDDD=0YYY000+0000DDD. CVD 3,DWORK DWORK NOW 000000000YYYDDDS. MVC 0(4,5),JDATE MOVE JDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. PERP300 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * SAVREGS DSECT DS 0D,18A CALLER SAVEREGS. DWORK DS 0D,4X JDATE DS PL4 0YYYDDDS * END TITLE 'RE-ENTRANT JULIAN(0YYYDDDS) TO PERPETUAL(DDDDDS)DATE' *---------------------------------------------------------------------* * CALL JULPERP,(JDATE,PDATE) 0100366C->36525C * LTR 15,15 Q,GOOD DATE CONVERSION? * BNZ ERRDATE N,HANDLE ERROR DATE. *---------------------------------------------------------------------* SPACE 2 JULPERP CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 2,3,0(1) LOAD CALLER INPUT/OUTPUT PARMS. UNPK JULDTE,0(4,2) JULDTE NOW CHARACTERS(YYYDDD). PACK DWORK,JULYYY PACK INPUT JULIAN YEAR. CVB 6,DWORK R6 NOW 00000YYY. LTR 4,6 TEST/MOVE INPUT JULIAN YEAR. BNP JUL300 EXIT, IF BAD INPUT JUL-YEAR. BCTR 6,0 R6/JULIAN YEAR LESS ONE. LR 5,6 R5=R6. SRL 5,2 DIV BY 4; R5=LEAP YEAR DAYS. MH 6,=Y(365) R6 DAYS IN PREV YEARS. AR 6,5 PLUS PREV LEAP YEAR DAYS. LA 5,365 ASSUMES NOT LEAP YEAR(365 DAYS). N 4,=A(3) Q,A LEAP YEAR? BNZ JUL200 N,365 DAY YEAR. LA 5,366 Y,366 DAY YEAR. JUL200 DS 0H PACK DWORK,JULDDD PACK INPUT JULIAN DAY. CVB 4,DWORK LTR 4,4 Q,POSITIVE INPUT JULIAN DAY. BNP JUL300 N,EXIT, INVALID INPUT JUL-DAY. CR 4,5 Q,DAYS > EOY (365/366)? BH JUL300 Y,EXIT, INVALID INPUT JUL-DAY. AR 4,6 R4 NOW BINARY PERPETUAL DATE. CVD 4,DWORK MVC 0(3,3),PDATE MOVES PDATE TO CALLER OUTPUT. XR 15,15 RETURN CODE: GOOD CONVERSION. JUL300 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * SAVREGS DSECT DS 0D,18A USER SAVEREGS. DWORK DS 0D,5X PDATE DS PL3 JULDTE DS 0CL6 YYYDDD JULYYY DS CL3 YYY JULDDD DS CL3 DDD * END TITLE 'RE-ENTRANT PERPETUAL DATE TO DAY OF WEEK' *---------------------------------------------------------------------* * CALL PERPDOW,(PDATE,DAYOFWEEK) * LTR 15,15 Q,GOOD DAY OF WEEK? * BNZ ERRDATE N,BAD INPUT PERP-DATE. *---------------------------------------------------------------------* SPACE 2 PERPDOW CSECT , RE-ENTRANT 1994ESOTO STM 14,12,12(13) SAVE CALLER REGISTERS. BALR 15,0 ESTABLISH ADDRESSABILITY. USING *,15 USING SAVREGS,13 CALLER RE-ENTRANT WORK AREA. LM 3,4,0(1) LOAD CALLER INPUT/OUTPUT PARMS. ZAP DWORK,0(3,3) MOVE/TEST INPUT PERP-DATE. BNP PERP200 EXIT, ZERO/NEGATIVE INPUT DATE. CVB 3,DWORK PACKED DECIMAL TO BINARY. XR 2,2 NEEDED FOR NEXT(DIVIDE) INSTR. D 2,=A(7) R2 NOW 0-6 (MON-SUN). MH 2,=Y(3) R2 NOW 0-18 (MON-SUN). LA 2,DOWTBL(2) R2 NOW POINTS TO DAY OF WEEK. MVC 0(3,4),0(2) MOVE DAY OF WEEK TO OUTPUT ADR. XR 15,15 RETURN CODE: GOOD. PERP200 DS 0H LM 0,12,20(13) RESTORE CALLER REGISTERS. BR 14 RETURN TO CALLER CONTROL. * LTORG * 0 1 2 3 4 5 6 DOWTBL DC C'MONTUEWEDTHUFRISATSUN' * SAVREGS DSECT DS 0D,18A CALLER SAVEREGS. DWORK DS D CALLER RE-ENTRANT WORK AREA * END