Date Conversion Routines

© Copyright Edward Soto 2003. All rights reserved.

Various Date Conversion Routines

This software is free; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.
More information is available from the Free Software Foundation or the Open Source Initiative.

This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with this software; if not, write to either of the following:

the Free Software Foundation, Inc.
59 Temple Place, Suite 330
Boston, MA 02111-1307
United States of America
B.V. Bixoft
Rogge 9
7261 JA Ruurlo
The Netherlands
  email: bixoft@bixoft.nl
phone: +31-6-22755401

Remark:
This software - and more programs and macros - are available in a format more suitable for uploading to your mainframe. Please e-mail B.V. Bixoft with your request and you will receive a zipped IEBUPDTE job with the program sources.


*                                                                       00000100
* This program is free software; you can redistribute it and/or modify  00000200
* it under the terms of the GNU General Public License as published by  00000300
* the Free Software Foundation; either version 2 of the License         00000400
* or (at your option) any later version.                                00000500
* The license text is available at the following internet addresses:    00000600
* - http://www.bixoft.com/english/gpl.htm                               00000700
* - http://fsf.org                                                      00000800
* - http://opensource.org                                               00000900
*                                                                       00001000
* This program is distributed in the hope that it will be useful,       00001100
* but WITHOUT ANY WARRANTY; without even the implied warranty of        00001200
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                  00001300
* See the GNU General Public License for more details.                  00001400
*                                                                       00001500
* You should have received a copy of the GNU General Public License     00001600
* along with this program; if not, write to either of the following:    00001700
* the Free Software Foundation, Inc.      B.V. Bixoft                   00001800
* 59 Temple Place, Suite 330              Rogge 9                       00001900
* Boston, MA 02111-1307                   7261 JA Ruurlo                00002000
* United States of America                The Netherlands               00002100
*                                                                       00002200
*                                         e-mail: bixoft@bixoft.nl      00002300
*                                         phone : +31-6-22755401        00002400
*                                                                       00002500

         TITLE 'RE-ENTRANT   GREGORIAN(YYYMMDDS)->JULIAN(0YYYDDDS)DATE'
*---------------------------------------------------------------------*
*        CALL  GREGJUL,(GDATE,JDATE)   1020710C->0102191C
*        LTR   R15,R15             Q, GOOD DATE CONVERSION?
*        BNZ   ERRDATE              NO, HANDLE INVALID INPUT GREG-DATE.
*---------------------------------------------------------------------*
         SPACE 2
GREGJUL  CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     GREG000
         DC    CL8'GREGJUL',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
GREG000  DS    0D
         LM    R4,R5,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES.
         UNPK  GREGDT,0(4,R4)      UNPACK/SAVE INPUT GREGORIAN DATE.
         PACK  DWORK,GREGYY        PACK GREGORIAN YEAR ONLY.
         CVB   R4,DWORK            R4 NOW 0000YYY.
         LA    R2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365)
         LTR   R3,R4               Q, YEAR ZERO(1900; 365 DAYS)?
         BZ    GREG100              YES, 365 DAYS CORRECT.
         N     R3,=A(3)            Q, LEAP YEAR(366 DAYS)?
         BNZ   GREG100              NO, MUST BE A 365 DAYS YEAR.
         LA    R2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366)
GREG100  DS    0H
         MH    R4,=Y(1000)         R4/FROM 0000YYY TO 0YYY000.
         PACK  DWORK,GREGMM        PACK GREGORIAN MONTH.
         CVB   R3,DWORK            R3 NOW 00000MM.
         LTR   R3,R3               Q, POSITIVE(VALID) GREGORIAN MONTH?  
         BNP   GREG900              NO, EXIT,INVALID GREGORIAN MONTH.
         CH    R3,=Y(12)           Q, GREGORIAN MONTH > 12 ?
         BH    GREG900              YES, EXIT,INVALID GREGORIAN MONTH.
         BCTR  R3,R0               R3 NOW 0-11.
         AR    R3,R3               R3 NOW 0-22.
         AR    R3,R2               R3 NOW CORRECT MONTH ENTRY.
         PACK  DWORK,GREGDD        PACK GREGORIAN DAY.
         CVB   R2,DWORK            R2 NOW 00000DD.
         LTR   R2,R2               Q, POSITIVE(VALID) GREGORIAN DAY?
         BNP   GREG900              NO, EXIT,INVALID GREGORIAN DAY.
         AH    R2,0(,R3)           GREGDD PLUS PREV MONTHS DAYS.
         CH    R2,2(,R3)           Q, GREGORIAN DAY > END OF MONTH?
         BH    GREG900              YES, EXIT, INVALID GREGORIAN DAY.
         AR    R2,R4               R2 = 0YYYDDD = 0YYY000 + 0000DDD.
         CVD   R2,DWORK            DWORK NOW 000000000YYYDDDS.  
         MVC   0(L'JDATE,R5),JDATE  MOVE JULIAN DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
GREG900  DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*
SAVREGS  DSECT
         DS    0D,18A        1x7   USER SAVEREGS.
DWORK    DS    0D,4X         2X7   DOUBLE WORD WORK AREA 
JDATE    DS    PL4           3X7   0YYYDDDS (OUTPUT JULIAN DATE)
GREGDT   DS    0CL7          4x7   YYYMMDD (INPUT GREGORIAN DATE)
GREGYY   DS    CL3           5x7   YYY
GREGMM   DS    CL2           6x7      MM
GREGDD   DS    CL2           7x7        DD
*
         END
 
 
 
         TITLE 'RE-ENTRANT   JULIAN(0YYYDDDS)->GREGORIAN(YYYMMDDS)DATE'
*---------------------------------------------------------------------*
*        CALL  JULGREG,(JDATE,GDATE)  0100366C->1001231C
*        LTR   R15,R15             Q, GOOD DATE CONVERSION?
*        BNZ   ERRDATE              NO, HANDLE INVALID JULIAN DATE.
*---------------------------------------------------------------------*
         SPACE 2 
JULGREG  CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     JUL000
         DC    CL8'JULGREG',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
JUL000   DS    0D
         LM    R4,R5,0(R1)         LOAD USER INPUT/OUTPUT ADDRESES.
         UNPK  JULDTE,0(4,R4)      UNPACK INPUT JULIAN DATE.
         PACK  DWORK,JULYYY        PACK JULIAN YEAR (3 DIGITS).
         CVB   R3,DWORK            R3 NOW 0000YYY.
         LA    R2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365)
         LTR   R1,R3               Q, YEAR ZERO(1900)? 
         BZ    JUL100               YES, 1900 NOT A LEAP YEAR.
         N     R1,=A(3)            Q, LEAP YEAR(366 DAYS)?
         BNZ   JUL100               NO, 365 DAYS YEAR CORRECT.
         LA    R2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366)
JUL100   DS    0H
         PACK  DWORK,JULDDD        PACK JULIAN DAY (3 DIGITS). 
         CVB   R4,DWORK            R4 NOW 0000DDD.
         CH    R4,24(,R2)          Q, JULIAN DAY > EOY(365/366)?
         BH    JUL900               YES, EXIT, ERROR JULIAN DAY.
         LTR   1,4                 LOAD/TEST JULIAN DAY.
         BNP   JUL900              EXIT, ERROR JULIAN DAY.
         SRL   R1,5                DIV BY 32; R1 NOW 0-11.
         LR    R0,R1               R0 NOW 0-11.
         AR    R0,R0               R0 NOW 0-22.
         AR    R2,R0               R2=CORRECT TABLE ENTRY, MAYBE.
         LA    R1,1(,R1)           R1=CORRECT MONTH, MAYBE.
         CH    R4,2(,R2)           Q, JULIAN DAY > NEXT ENTRY.
         BNH   JUL200               NO, R1/R2 CORRECT MONTH/ENTRY.
         LA    R1,1(,R1)           R1 NOW CORRECT MONTH(1-12).
         LA    R2,2(,R2)           R2 NOW CORRECT ENTRY.
JUL200   DS    0H
         SH    R4,0(,R2)           R4 NOW CORRECT GREG DAY.
         MH    R1,=Y(100)          R1/FROM 00000MM TO 000MM00.
         AR    R1,R4               R1=000MMDD = 000MM00 + 00000DD.
         MH    R3,=Y(10000)        R3 FROM 0000YYY TO YYY0000. 
         AR    R3,R1               R3=YYYMMDD = YYY0000 + 000MMDD.
         CVD   R3,DWORK            DWORK NOW 00000000YYYMMDDC.
         MVC   0(L'GDATE,R5),GDATE  MOVE GREG-DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
JUL900   DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*        
SAVREGS  DSECT
         DS    0D,18A        1X6   USER SAVEREGS. 
DWORK    DS    0D,4X         2X6
GDATE    DS    PL4           3X6   YYYMMDDS (OUTPUT GREG DATE)
JULDTE   DS    0CL6          4X6   YYYDDD (INPUT JULIAN DATE)
JULYYY   DS    CL3           5X6   YYY
JULDDD   DS    CL3           6X6      DDD
*
         END
 
 
 
         TITLE 'RE-ENTRANT  PERPETUAL(DDDDDS)DATE->GREGORIAN(YYYMMDDS)'
*---------------------------------------------------------------------*
*        CALL  PERPGREG,(PDATE,GDATE)  36525C=>1001231C
*        LTR   R15,R15             Q, GOOD DATE CONVERSION?
*        BNZ   ERRDATE              NO, HANDLE INVALID INPUT PERP-DATE.
*---------------------------------------------------------------------*
         SPACE 2
PERPGREG CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     PERP000
         DC    CL8'PERPGREG',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
PERP000  DS    0D
         LM    R4,R5,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES.
         ZAP   DWORK,0(3,R4)       MOVE/TEST INPUT PERP-DATE.
         BNP   PERP900             EXIT, INVALID INPUT PERP-DATE.
         CVB   R4,DWORK            R4 NOW BINARY PERPETUAL DATE.
         LR    R3,R4               R3=R4
         XR    R2,R2               NEEDED FOR NEXT INSTR.
         D     R2,=A(365)          R3 PROBABLY GOOD WORK YEAR.
         LR    R1,R3               R1=R3
         SRL   R1,2                R1 NUMBER OF LEAP YEAR DAYS.
         CR    R1,R2               Q, LEAP YEAR DAYS < REMAINDER?
         BL    PERP100              YES, R3 GOOD WORK YEAR.
         BCTR  R3,R0                NO, R3 NOW GOOD WORK YEAR.
PERP100  DS    0H
         LR    R2,R3               NEEDED FOR LEAP YEAR DAYS CALC.
         LR    R1,R3               NEEDED BY NEXT INSTR.
         M     R0,=A(365)          R1 NOW DAYS W/O LEAP YEAR DAYS.
         SRL   R2,2                R2 NOW CORRECT LEAP YEAR DAYS.
         AR    R2,R1               R2 NOW DAYS IN PREV-YEARS.
         SR    R4,R2               R4 NOW CURRENT YEAR DAYS.
         LA    R3,1(,R3)           R3 NOW CURRENT OUTPUT GREG-YEAR.
         LA    R0,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365)
         N     2,=A(3)             Q, A LEAP YEAR?
         BNZ   PERP200              NO, ASSUMPTION CORRECT.
         LA    R0,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366)
PERP200  DS    0H
         LR    R2,R4               MOVE DAYS IN CURRENT YEAR.
         SRL   R2,5                DIVIDE BY 32; R2 NOW 0-11.
         LR    R1,R2               R1 NOW 0-11.
         AR    R1,R1               R1 NOW 0-22.
         AR    R1,R0               R1 MAYBE CORRECT MONTH ENTRY.
         LA    R2,1(,R2)           R2 MAYBE CORRECT MONTH (1-12).
         CH    R4,2(,R1)           Q, CORRECT MONTH ENTRY?
         BNH   PERP300              YES, SKIP ADJUSTMENT.
         LA    R1,2(,R1)           R1 NOW CORRECT MONTH (1-12).
         LA    R2,1(,R2)           R2 NOW CORRECT GREG-MONTH.
PERP300  DS    0H
         SH    R4,0(,R1)           R4 NOW OUTPUT GREG DAY(00000DD).
         MH    R3,=Y(10000)        R3/FROM 0000YYY TO YYY0000.
         MH    R2,=Y(100)          R2/FROM 00000MM TO 000MM00.
         AR    R2,R3               R2 NOW YYYMM00. 
         AR    R2,R4               R2 NOW YYYMMDD.
         CVD   R2,DWORK            DWORK NOW 00000000YYYMMDDS.
         MVC   0(L'GDATE,R5),GDATE  MOVE GREG-DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
PERP900  DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*
SAVREGS  DSECT
         DS    0D,18A        1X3   USER SAVEREGS.
DWORK    DS    0D,4X         2X3
GDATE    DS    PL4           3X3   YYYMMDDS (OUTPUT GREG DATE)
*
         END
 
 
 
         TITLE 'RE-ENTRANT  GREGORIAN(YYYMMDDS)->PERPETUAL(DDDDDS)DATE'
*---------------------------------------------------------------------*
*        CALL  GREGPERP,(GDATE,PDATE)   1001231C->36525C
*        LTR   R15,R15             Q, GOOD DATE CONVERSION?
*        BNZ   ERRDATE              NO, HANDLE INVALID GREGORIAN DATE.
*---------------------------------------------------------------------*
         SPACE 2
GREGPERP CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     GREG000
         DC    CL8'GREGPERP',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
GREG000  DS    0D
         LM    R4,R5,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES.
         UNPK  GREGDT,0(4,R4)      SAVE/UNPACK INPUT GREGORIAN-DATE.
         PACK  DWORK,GREGYY        PACK INPUT GREGORIAN YEAR.
         CVB   R4,DWORK            R4 NOW 00000YYY.
         LTR   R3,R4               Q, YEAR ZERO(1900)?
         BZ    GREG900              YES, EXIT; INVALID OUTPUT YEAR.
         LA    R2,=Y(0,31,59,90,120,151,181,212,243,273,304,334,365)
         N     R3,=A(3)            Q, A LEAP YEAR(366 DAYS)?
         BNZ   GREG100              NO, MUST BE 365 DAYS YEAR.
         LA    R2,=Y(0,31,60,91,121,152,182,213,244,274,305,335,366)
GREG100  DS    0H
         PACK  DWORK,GREGMM        PACK INPUT GREGORIAN MONTH.
         CVB   R3,DWORK            R3 NOW BINARY GREGORIAN MONTH.
         LTR   R3,R3               Q, POSITIVE GREGORIAN MONTH?
         BNP   GREG900              NO, EXIT; INVALID INPUT GREG-MONTH.
         CH    R3,=Y(12)           Q, INPUT GREGORIAN MONTH > 12 ?
         BH    GREG900              YES, EXIT; INVALID GREGORIAN MONTH.
         BCTR  R3,R0               R3 NOW 0-11.
         AR    R3,R3               R3 NOW 0-22.
         AR    R3,R2               R3 NOW CORRECT MONTH-TBL ENTRY.
         PACK  DWORK,GREGDD        PACK INPUT GREGORIAN DAY.  
         CVB   R2,DWORK 
         LTR   R2,R2               Q, POSITIVE INPUT GREGORIAN DAY?
         BNP   GREG900              NO, EXIT; INVALID INPUT GREG-DAY.
         AH    R2,0(,R3)           PREV MONTH DAYS TO GREGORIAN DAY.
         CH    R2,2(,R3)           Q, GREGORIAN DAY > END OF MONTH ? 
         BH    GREG900              YES, EXIT; INVALID GREGORIAN DAY.
         BCTR  R4,R0               DECREMENT BY 1 INPUT GREGORIAN YEAR.
         LR    R3,R4               R3=R4.
         SRL   R3,2                R3 NOW LEAP YEAR DAYS.
         MH    R4,=Y(365)          R4 DAYS IN PREV YRS LESS LEAP.
         AR    R4,R3               R4 NOW DAYS IN PREV YEARS.
         AR    R4,R2               R4 NOW BINARY PERPETUAL DATE.
         CVD   R4,DWORK            DWORK NOW 0000000000DDDDDS.
         MVC   0(L'PDATE,R5),PDATE  MOVE PERP-DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
GREG900  DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL. 
*
         LTORG
*
SAVREGS  DSECT
         DS    0D,18A        1X7   USER SAVEREGS.
DWORK    DS    0D,5X         2X7
PDATE    DS    PL3           3X7   DDDDDS
GREGDT   DS    0CL7          4X7   YYYMMDD
GREGYY   DS    CL3           5X7   YYY
GREGMM   DS    CL2           6X7      MM
GREGDD   DS    CL2           7X7        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              NO, HANDLE INVALID PERPETUAL DATE.
*---------------------------------------------------------------------*
         SPACE 2
PERPJUL  CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     PERP000
         DC    CL8'PERPJUL',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
PERP000  DS    0D
         LM    R4,R5,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES.
         ZAP   DWORK,0(3,R4)       MOVE/TEST INPUT PERPETUAL DATE.
         BNP   PERP900             EXIT, BAD INPUT PERPETUAL DATE.
         CVB   R4,DWORK            R4 NOW BINARY PERPETUAL DATE.
         LR    R3,R4               R3=R4.
         XR    R2,R2               NEEDED FOR NEXT INSTR.
         D     R2,=A(365)          R3 NOW PROBABLY GOOD WORK YEAR.
         LR    R1,R3               R1=R3.
         SRL   R1,2                DIV BY 4; R1 NOW LEAP YEAR DAYS.
         CR    R1,R2               Q, LEAP YEAR DAYS < REMAINDER?
         BL    PERP100              YES, R3 GOOD WORK YEAR.
         BCTR  R3,R0                NO, R3 NOW GOOD WORK YEAR.
PERP100  DS    0H
         LR    R2,R3               R2=R3.
         LR    R1,R3               R1=R3.
         M     R0,=A(365)          R1=PREV YRS DAYS,W/O LEAP DAYS.
         SRL   R2,2                R2 NOW PREV LEAP YEAR DAYS.
         AR    R2,R1               R2 NOW PREV YEARS DAYS.
         SR    R4,R2               R4 NOW DAYS IN CURRENT YEAR.
         LA    R3,1(,R3)           R3 NOW CORRECT OUTPUT JUL-YEAR.
         MH    R3,=Y(1000)         R3 FROM 0000YYY TO 0YYY000.
         AR    R3,R4               R3 NOW 0YYYDDD=0YYY000+0000DDD. 
         CVD   R3,DWORK            DWORK NOW 000000000YYYDDDS.
         MVC   0(L'JDATE,R5),JDATE  MOVE JULIAN DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
PERP900  DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*
SAVREGS  DSECT
         DS    0D,18A        1X3   USER SAVEREGS.
DWORK    DS    0D,4X         2X3   DOUBLE WORD WORK AREA.
JDATE    DS    PL4           3X3   0YYYDDDS
*
         END
 
 
 
         TITLE 'RE-ENTRANT   JULIAN(0YYYDDDS) TO PERPETUAL(DDDDDS)DATE'
*---------------------------------------------------------------------*
*        CALL  JULPERP,(JDATE,PDATE)  0100366C->36525C
*        LTR   R15,R15             Q, GOOD DATE CONVERSION?
*        BNZ   ERRDATE              NO, HANDLE INVALID JULIAN DATE.
*---------------------------------------------------------------------*
         SPACE 2
JULPERP  CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     JUL000
         DC    CL8'JULPERP',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
JUL000   DS    0D
         LM    R2,R3,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES.
         UNPK  JULDTE,0(4,R2)      JULDTE NOW CHARACTERS(YYYDDD).
         PACK  DWORK,JULYYY        PACK INPUT JULIAN YEAR.
         CVB   R6,DWORK            R6 NOW 00000YYY.
         LTR   R4,R6               TEST/MOVE INPUT JULIAN YEAR.
         BNP   JUL900              EXIT, IF BAD INPUT JULIAN-YEAR.
         BCTR  R6,R0               R6/JULIAN YEAR LESS ONE.
         LR    R5,R6               R5=R6.
         SRL   5,2                 DIV BY 4; R5 NOW LEAP YEAR DAYS.
         MH    R6,=Y(365)          R6 DAYS IN PREV YEARS.
         AR    R6,R5               PLUS PREV LEAP YEAR DAYS.
         LA    R5,365              ASSUMES NOT LEAP YEAR (365 DAYS).
         N     R4,=A(3)            Q, A LEAP YEAR?
         BNZ   JUL100               NO, 365 DAYS YEAR.
         LA    R5,366               YES, 366 DAYS YEAR.
JUL100   DS    0H
         PACK  DWORK,JULDDD        PACK INPUT JULIAN DAY. 
         CVB   R4,DWORK
         LTR   R4,R4               Q, POSITIVE INPUT JULIAN DAY.
         BNP   JUL900               NO, EXIT, INVALID INPUT JUL-DAY.
         CR    R4,R5               Q, DAYS >  EOY (365/366)?
         BH    JUL900               YES, EXIT, INVALID INPUT JUL-DAY.
         AR    R4,R6               R4 NOW BINARY PERPETUAL DATE.
         CVD   R4,DWORK            DWORK NOW 0000000000DDDDDS.
         MVC   0(L'PDATE,R3),PDATE  MOVES PERP-DATE TO USER OUTPUT.
         XR    R15,R15             RETURN CODE: GOOD CONVERSION.
JUL900   DS    0H
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*
SAVREGS  DSECT
         DS    0D,18A        1X6   USER SAVEREGS.
DWORK    DS    0D,5X         2X6   DOUBLE WORD WORK AREA
PDATE    DS    PL3           3X6   OUTPUT PERPETUAL DATE
JULDTE   DS    0CL6          4X6   YYYDDD
JULYYY   DS    CL3           5X6   YYY
JULDDD   DS    CL3           6X6      DDD
*
         END
 
 
 
         TITLE 'RE-ENTRANT               PERPETUAL DATE TO DAY OF WEEK'
*---------------------------------------------------------------------*
*        CALL  PERPDOW,(PDATE,DAYWEEK)
*        LTR   R15,R15             Q, GOOD DAY OF WEEK?
*        BNZ   ERRDATE              NO, HANDLE INVALID PERPETUAL DATE.
*---------------------------------------------------------------------*
         SPACE 2  
PERPDOW  CSECT ,                   RE-ENTRANT            2006JAN18ESOTO
         USING *,R15
         USING SAVREGS,R13         USER RE-ENTRANT WORK AREA.
         PRINT NOGEN
         YREGS ,                   EQUATES REGISTERS 0-15 TO R0-R15.
         STM   R14,R12,12(R13)     STORE USER REGISTERS.
         B     PERP000
         DC    CL8'PERPDOW',CL8'&SYSDATE',CL8'&SYSTIME',CL8'&VER'
PERP000  DS    0D
         LM    R3,R4,0(R1)         LOAD USER INPUT/OUTPUT ADDRESSES. 
         ZAP   DWORK,0(3,R3)       MOVE/TEST INPUT PERPETUAL DATE.
         BNP   PERP900             EXIT, ZERO OR NEGATIVE INPUT DATE.
         CVB   R3,DWORK            CONVERT PACKED DECIMAL TO BINARY.
         XR    R2,R2               NEEDED FOR NEXT (DIVIDE) INSTR.
         D     R2,=A(7)            R2 (REMAINDER) NOW 0-6 (MON-SUN).
         MH    R2,=Y(3)            R2 NOW 0-18 (MON-SUN).
         LA    R2,DOWTBL(R2)       R2 NOW POINTS TO DAY OF WEEK.
         MVC   0(3,R4),0(R2)       MOVE DAY OF WEEK TO OUTPUT ADDRESS.
         XR    R15,R15             RETURN CODE: VALID INPUT/RESULTS.
PERP900  DS    0H  
         LM    R0,R12,20(R13)      RESTORE USER REGISTERS.
         BR    R14                 RETURN TO USER CONTROL.
*
         LTORG
*                 0  1  2  3  4  5  6   POSSIBLE REMAINDERS (0-6).
DOWTBL   DC    C'MONTUEWEDTHUFRISATSUN'
*
SAVREGS  DSECT              
         DS    0D,18A        1X2   USER SAVEREGS. 
DWORK    DS    D             2X2   USER RE-ENTRANT WORK AREA
*
         END

 

This site is a member of WebRing.
You are invited to browse the list of mainframe-loving sites.
Running
    Tyrannosaurus Rex Dinos are not dead. They are alive and well and living in data centers all around you. They speak in tongues and work strange magics with computers. Beware the dino! And just in case you're waiting for the final demise of these dino's: remember that dinos ruled the world for 155-million years!
Dinos and other anachronisms
[ Join Now | Ring Hub | Random | << Prev | Next >> ]
 

Below you find the logo of our sponsor and logos of the web-standards that this page adheres to.