!***********************************************************************
!*                                                                     *
!* THESE FUNCTIONS ALL USE A PACKED FORMAT OF DATE AND TIME OF ONE OF  *
!* THE FOLLOWING FORMS.BITS ARE NUMBERED FROM 31 (MOST SIGNIFICANT) TO *
!* 0 (LEAST SIGNIFICANT)                                               *
!* OLD FORMAT                                                          *
!* BITS    USE                                                         *
!* 31      ZERO FOR OLD FORMAT                                         *
!* 30-26  YEAR-70  (VALID FOR 1970-2033)                               *
!* 25-22  MONTH                                                        *
!* 21-17  DAY                                                          *
!* 16-12  HOUR                                                         *
!* 11- 6  MINUTE                                                       *
!*  5- 0  SECOND                                                       *
!*                                                                     *
!*  NEW FORMAT                                                         *
!*  BIT31 1 FOR NEW FORMAT                                             *
!*    ALL OTHER BITS HOLD DT AS SECS SINCE 0000HRS ON 1/1/70           *
!*    CALCULATED AS PER CACM COLLECTER ALGORITHMS NO 199Z              *
!*    NB TO KEEP LEAP YEARS CORRECT ONE MUST USE THIS ALGORITH FROM    *
!*    1ST JAN 1900 AND THEN CORRECT. THIS INVOLVES 64BIT ARITHMETIC    *
!***********************************************************************

%CONSTINTEGER SECSIN24HRS=86400;        ! SECS IN DAY
%CONSTINTEGER DAYS70=25567;             ! DAYS FROM JAN1 1900 TO JAN1 1970
%CONSTLONGINTEGER SECS70=X'0000000083AA7E80';! SECS DITTOM
%INTEGERFN KDAY(%INTEGER D,M,Y)
!***********************************************************************
!*    RETURNS DAYS SINCE 1900 GIVEN DAY MONTH &YEAR(<=99)              *
!***********************************************************************
      %IF M>2 %THEN M=M-3 %ELSE M=M+9 %AND Y=Y-1
      %RESULT=1461*Y//4+(153*M+2)//5+D+58
%END
%ROUTINE KDATE(%INTEGERNAME D,M,Y,%INTEGER K)
!***********************************************************************
!*    K IS DAYS SINCE 1ST JAN 1900                                     *
!*    RETURNS D, M, Y   2 DIGIT Y ONLY                                 *
!***********************************************************************
!      %INTEGER W
!      K=K+693902;                       ! DAYS SINCE CEASARS BDAY
!      W=4*K-1
!      Y=W//146097
!      K=W-146097*Y
!      D=K//4
!      K=(4*D+3)//1461;
!      D=4*D+3-1461*K
!      D=(D+4)//4
!      M=(5*D-3)//153
!      D=5*D-3-153*M
!      D=(D+5)//5
!      Y=K
      *LSS_K; *IAD_693902
      *IMY_4; *ISB_1; *IMDV_146097
      *LSS_%TOS; *IDV_4; *IMY_4; *IAD_3
      *IMDV_1461; *ST_(Y)
      *LSS_%TOS; *IAD_4; *IDV_4
      *IMY_5; *ISB_3; *IMDV_153
      *ST_(M); *LSS_%TOS
      *IAD_5; *IDV_5; *ST_(D)
      %IF M<10 %THEN M=M+3 %ELSE M=M-9 %AND Y=Y+1
%END; ! OF KDATE
%INTEGERFN CURRENT PACKED DT
!***********************************************************************
!*    GIVES CURRENT DT IN NEW PACKED FORM                              *
!***********************************************************************
%CONSTLONGINTEGER MILL=1000000
      *RRTC_0; *USH_-1
      *SHS_1; *USH_1
      *IMDV_MILL
      *ISB_SECS70; *STUH_%B
      *OR_X'80000000'
      *EXIT_-64
%END
%ROUTINE DECWRITE2(%INTEGER VALUE,AD)
!***********************************************************************
!*    WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1          *
!***********************************************************************
      *LSS_VALUE; *IMDV_10
      *USH_8; *IAD_%TOS; *IAD_X'3030'
      *LDA_AD; *LDTB_X'58000002'
      *ST_(%DR)
%END; ! OF DECWRITE2
%INTEGERFN I2(%INTEGER AD)
!AD POINTS TO THE FIRST OF A PAIR OF DECIMAL CHARACTERS. THE RESULT
!IS THE NUMERIC VALUE OF THE CHAS
   %RESULT = 10*(BYTEINTEGER(AD)&X'F')+(BYTEINTEGER(AD+1)&X'F')
%END;                                   !OF I2

%INTEGERFN PACKDATE(%STRING (8) DATE)
%INTEGER AD,I
      AD = ADDR(DATE)
      I=KDAY(I2(AD+1),I2(AD+4),I2(AD+7))-DAYS70
      %RESULT=I*SECSIN 24 HRS!X'80000000'
%END;                                   !OF PACKDATE

%INTEGERFN PACKDATEANDTIME(%STRING (8) DATE, TIME)
%INTEGER AT
      AT = ADDR(TIME)
      %RESULT=PACKDATE(DATE)+3600*I2(AT+1)+60*I2(AT+4)+I2(AT+7)
%END;                                   !OF PACKDATEANDTIME
%STRING(8)%FN UNPACK TIME(%INTEGER P)
%INTEGER H,M,SECS,AT
%STRING(8)S
      AT=ADDR(S)
      S="00:00:00"
      %IF P>0 %START
         H=P>>12&31
         M=P>>6&63
         SECS=P&63
      %FINISH %ELSE %START
         *LSS_P; *USH_1; *USH_-1
         *IMDV_60; *IMDV_60; *IMDV_24
         *LSS_%TOS; *ST_H
         *LSS_%TOS; *ST_M
         *LSS_%TOS; *ST_SECS
      %FINISH
      DECWRITE2(H,AT+1)
      DECWRITE2(M,AT+4)
      DECWRITE2(SECS,AT+7)
      %RESULT=S
%END
%STRING(8)%FN UNPACK DATE(%INTEGER P)
%INTEGER D,M,Y,AD
%STRING(8)S
      AD=ADDR(S)
      S="00/00/00"
      %IF P>0 %THEN %START;             ! OLD FORMAT
         Y=P>>26+70
         M=P>>22&15
         D=P>>17&31
      %FINISH %ELSE %START
         P=(P&X'7FFFFFFF')//SECS IN 24 HRS
         KDATE(D,M,Y,P+DAYS70)
      %FINISH
      DECWRITE2(D,AD+1)
      DECWRITE2(M,AD+4)
      DECWRITE2(Y,AD+7)
      %RESULT=S
%END

%ENDOFFILE