PUNCH 'CATALOG DATENUM.OBJ R=Y'
DATENUM  START 0
**********************************************************************
* THIS SUBPROGRAM CALCULATES THE NUMBER OF DAYS SINCE JAN. 1,0001    *
* UP TO THE DATE (YYYYMMDD) ENTERED. IT ALSO RETURNS A NUMERIC       *
* VALUE THAT REPRESENTS THE WEEKDAY THAT THAT DAY FALLS ON.          *
* 0=SUNDAY, 1=MONDAY...6=SATURDAY.                                   *
* ROUTINE TAKES LEAP YEARS INTO EFFECT. 365 DAYS A YEAR WITH AN      *
* EXTRA DAY (FEB 29) IF THE YEAR IS EVENLY DIVISIBLE BY 4, EXCEPT    *
* CENTURY YEARS WHICH MUST BE EVENLY DIVISIBLE BY 400.               *
*                                                                    *
* INPUT:  CL8  YYYYMMDD.                                             *
* OUTPUT: PL4  DDDDDD. RETURN PACKED ZEROES IF INPUT INVALID.        *
* OUTPUT: PL1  D. (WEEKDAY)                                          *
*                                                                    *
* PROGRAMMER: BILL BLASINGIM                                         *
* WRITTEN   : NOVEMBER 8, 1995                                       *
**********************************************************************
         PRINT NOGEN
         SAVE  (14,12)
START    BALR  12,0
         USING *,12
         ST    R13,SAVEAREA+4
         LA    R13,SAVEAREA
         LM    R4,R6,0(1)
*        R4 = ADDRESS OF YYMMDD INPUT
*        R5 = ADDRESS OF JULIAN OUTPUT
*        R6 = DAY OF WEEK
*
         LR    R7,R4
         LA    R8,8
CHKNUM   CLI   0(R7),C'0'         CHECK FOR VALID NUMBERS
         BL    BADNUM
         CLI   0(R7),C'9'
         BH    BADNUM
         LA    R7,1(,R7)
         BCT   R8,CHKNUM
CHKDATE  EQU   *
         PACK  MM,4(2,R4)         PACK MONTH
         CVB   R7,MMDBL           CONVERT MONTH TO BINARY
*        MAKE SURE MONTH IS 1-12
         CP    MM,=P'1'
         BL    BADNUM
         CP    MM,=P'12'
         BH    BADNUM
*
         PACK  YYYY,0(4,R4)
         MVC   THISYEAR,YYYY      SAVE THIS YEAR
         SP    YYYY,=P'1'         SUB 1 FOR TOTAL DAYS UP TO LAST YEAR
         ZAP   DAYTOT,YYYY
         DP    YYYY,=P'100'
         ZAP   EXCLUDE,YYYY+3(2)  PACK CENTURY PART OF YEAR
         MVC   LEAPS,DAYTOT       SAVE PACKED YEAR
         ZAP   YYYY,DAYTOT        SAVE PACKED YEAR
         DP    YYYY,=P'400'
         SP    EXCLUDE,YYYY(5)
         MVC   YYYY(5),LEAPS      SAVE YYYY AGAIN FOR LATER
         DP    LEAPS,=P'4'
         ZAP   LEAPS,LEAPS(4)
*        CHECK FOR LEAP YEAR
         ZAP   FEB,=P'28'
         CLC   2(2,R4),=CL2'00'
         BNE   NOTCENT
         DP    THISYEAR,=P'400'
         CP    THISYEAR+5(2),=P'0'
         BE    LEAP
         B     NOTLEAP
NOTCENT  EQU   *
         DP    THISYEAR,=P'4'
         CP    THISYEAR+6(1),=P'0'
         BNE   NOTLEAP
LEAP     AP    FEB,=P'1'
NOTLEAP  EQU   *
         SP    LEAPS,EXCLUDE+1(4) GET # OF LEAP YEARS
         MP    DAYTOT,=P'365'     YEARS * 365
         AP    DAYTOT,LEAPS         + LEAP YEARS
*
         LA    R8,MONTHDAY
         PACK  DD,6(2,R4)         PACK DAY
         CP    DD,=P'1'           MAKE SURE DAY GREATER THAN ZERO
         BL    BADNUM
         CP    MM,=P'1'
         BE    LOOPEXT
         SH    R7,=H'1'           MONTH LOOP
DAYSUM   EQU   *
         AP    DAYTOT,0(2,R8)
         LA    R8,2(,R8)          NEXT ELEMENT
         BCT   R7,DAYSUM
LOOPEXT  EQU   *
         CP    DD,0(2,R8)         MAKE SURE DAY NOT > MONTHDAY
         BH    BADNUM
         AP    DAYTOT,DD          ADD FINAL DAY
         MVC   0(4,R5),DAYTOT+1   MOVE OUT DAY TOTAL
         DP    DAYTOT,=P'7'       REMAINDER: WEEKDAY 0=SUN...6=SAT
         ZAP   MM,DAYTOT+4(1)
         CVB   R7,MMDBL           CONVERT MONTH TO BINARY
         STH   R7,0(0,R6)
*        PDUMP MMDBL,FEB+2
GOBACK   L     R13,SAVEAREA+4
         RETURN (14,12)
BADNUM   EQU   *
         ZAP   0(4,R5),=P'0'
         MVC   0(2,R6),=H'7'      0-6 VALID FOR DAY OF WEEK
         B     GOBACK
**********************************************************************
*                                                                    *
*                 S T O R A G E   A R E A                            *
*                                                                    *
**********************************************************************
MMDBL    DS   0D        MONTH DOUBLEWORD FOR CVB
         DC   6X'00'
MM       DC   PL2'0'
DD       DC   PL2'0'
YYYY     DS   PL7
THISYEAR DS   PL7
LEAPS    DS   PL5
EXCLUDE  DS   PL5
DAYTOT   DC   PL5'0'
MONTHDAY DS   0CL24
         DC   P'31'     JANUARY
FEB      DC   P'28'     FEBRUARY
         DC   P'31'     MARCH
         DC   P'30'     APRIL
         DC   P'31'     MAY
         DC   P'30'     JUNE
         DC   P'31'     JULY
         DC   P'31'     AUGUST
         DC   P'30'     SEPTEMBER
         DC   P'31'     OCTOBER
         DC   P'30'     NOVEMBER
         DC   P'31'     DECEMBER
SAVEAREA DS   9D
         REGEQU
         END  START