PUNCH 'CATALOG DATEADD.OBJ R=Y'
DATEADD  START 0
**********************************************************************
* THIS SUBPROGRAM ADDS A NUMBER OF DAYS TO A DATE YYYYMMDD AND       *
* RETURNS THE NEW DATE.                                              *
*                                                                    *
* INPUT:  CL8  YYYYMMDD DATE 1.                                      *
* INPUT:  PL3  # OF DAYS TO ADD. NEGATIVE # FOR DAYS TO SUBTRACT.    *
* OUTPUT: CL8  YYYYMMDD NEW DATE. RETURN ALL ZEROES FOR INVALID DATA.*
*                                                                    *
* 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 DATE (YYMMDD) (INPUT)
*        R5 = ADDRESS OF DAYS TO ADD (INPUT)
*        R6 = ADDRESS OF NEW DATE (YYMMDD) (OUTPUT)
*
         MVC   YYYYMMDD,0(R4)
         CALL  JDATE,(YYYYMMDD,JULPACK)
         CP    JULPACK,=P'0'
         BE    BADNUM
         UNPK  JULDISP,0(3,R5)
         OI    JULDISP+6,X'F0'
         LA    R7,JULDISP
         LA    R8,7
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
DATEOK   EQU   *
*
         PACK  YYYYBEG,0(4,R4)    GET PACKED YEAR
         CP    0(3,R5),=P'0'
         BNL   FUTURE
*        SUBTRACT DAYS TO GO BACK IN THE PAST
         ZAP   TOTDAYS,JULPACK+2(2)
         AP    TOTDAYS,0(3,R5)    ADD A NEGATIVE NUMBER
         B     SUBCOMP
SUBLOOP  EQU   *
         SP    YYYYBEG,=P'1'
         ZAP   YYYY,YYYYBEG+3(3)
         ZAP   YEARDAYS,=P'365'
*        CHECK FOR LEAP YEAR
         CLC   2(2,R4),=CL2'00'   CENTURY YEAR?
         BNE   NOTCENT1
*        PACK  YYYY,0(4,R4)
         DP    YYYY,=P'400'
         CP    YYYY+5(2),=P'0'
         BE    ADDONE1
         B     NOTLEAP1
NOTCENT1 EQU   *
*        PACK  YYYY,0(4,R4)
         DP    YYYY,=P'4'
         CP    YYYY+6(1),=P'0'
         BNE   NOTLEAP1
ADDONE1  AP    YEARDAYS,=P'1'
NOTLEAP1 EQU   *
         AP    TOTDAYS,YEARDAYS
SUBCOMP  EQU   *
*        PDUMP YYYYMMDD,TOTDAYS+5
         CP    TOTDAYS,=P'1'
         BL    SUBLOOP
         B     DAYEXIT
*
FUTURE   EQU   *                  ADD DAYS TO GO TO THE FUTURE
         ZAP   TOTDAYS,JULPACK+2(2)
         AP    TOTDAYS,0(3,R5)    TOTAL DAYS TO ADD
DAYLOOP  EQU   *
         ZAP   YYYY,YYYYBEG+3(3)
         ZAP   YEARDAYS,=P'365'
*        CHECK FOR LEAP YEAR
         CLC   2(2,R4),=CL2'00'
         BNE   NOTCENT
*        PACK  YYYY,0(4,R4)
         DP    YYYY,=P'400'
         CP    YYYY+5(2),=P'0'
         BE    ADDONE
         B     NOTLEAP
NOTCENT  EQU   *
         PACK  YYYY,0(4,R4)
         DP    YYYY,=P'4'
         CP    YYYY+6(1),=P'0'
         BNE   NOTLEAP
ADDONE   AP    YEARDAYS,=P'1'
NOTLEAP  EQU   *
         CP    TOTDAYS,YEARDAYS
         BNH   DAYEXIT
         AP    YYYYBEG,=P'1'
         SP    TOTDAYS,YEARDAYS
         B     DAYLOOP
DAYEXIT  EQU   *
         MP    YYYYBEG,=P'1000'     CHANGE YY TO YY000
         AP    YYYYBEG,TOTDAYS      ADD DAYS TO YY000
         UNPK  JULDISP,YYYYBEG
         OI    JULDISP+6,X'F0'
*  THIS SUBROUTINE RETURNS ZEROES IN YYMMDD FOR BAD DATA
         CALL  JDATE2,(JULDISP,YYYYMMDD)
         MVC   0(8,R6),YYYYMMDD
*        PDUMP YYYYMMDD,TOTDAYS+5
GOBACK   L     R13,SAVEAREA+4
         RETURN (14,12)
BADNUM   EQU   *
         MVC   0(8,R6),=CL8'00000000'
         B     GOBACK
**********************************************************************
*                                                                    *
*                 S T O R A G E   A R E A                            *
*                                                                    *
**********************************************************************
         DS   0D
YYYYMMDD DS   CL8
JULDISP  DS   CL7       YYYYDDD
JULPACK  DS   PL4       YY YY DD DS
YYYYBEG  DC   PL6'0'    00 00 0Y YY YS
YEARDAYS DC   PL2'0'
YYYY     DC   PL7'0'
MM       DC   PL2'0'
DD       DC   PL2'0'
TOTDAYS  DC   PL5'0'
SAVEAREA DS   9D
         REGEQU
         END  START