MODULE date_sub ! COLLECTED AND PUT TOGETHER JANUARY 1972, H. D. KNOBLE . ! ORIGINAL REFERENCES ARE CITED IN EACH ROUTINE. ! Code converted using TO_F90 by Alan Miller ! Date: 1999-12-22 Time: 10:23:47 IMPLICIT NONE CONTAINS ! ARITHMETIC FUNCTIONS 'IZLR' AND 'IDAY' ARE TAKEN FROM REMARK ON ! ALGORITHM 398, BY J. DOUGLAS ROBERTSON, CACM 15(10):918. FUNCTION iday(yyyy, mm, dd) RESULT(ival) !------IDAY IS A COMPANION TO CALEND; GIVEN A CALENDAR DATE, YYYY, MM, ! DD, IDAY IS RETURNED AS THE DAY OF THE YEAR. ! EXAMPLE: IDAY(1984, 4, 22) = 113 INTEGER, INTENT(IN) :: yyyy, mm, dd INTEGER :: ival ival = 3055*(mm+2)/100 - (mm+10)/13*2 -91 + (1-(MOD(yyyy, 4)+3)/4 + & (MOD(yyyy, 100) + 99)/100 - (MOD(yyyy, 400)+399)/400)*(mm+10)/13 + dd RETURN END FUNCTION iday FUNCTION izlr(yyyy, mm, dd) RESULT(ival) !------IZLR(YYYY, MM, DD) GIVES THE WEEKDAY NUMBER 0 = SUNDAY, 1 = MONDAY, ! ... 6 = SATURDAY. EXAMPLE: IZLR(1970, 1, 1) = 4 = THURSDAY INTEGER, INTENT(IN) :: yyyy, mm, dd INTEGER :: ival ival = MOD((13*(mm+10-(mm+10)/13*12)-1)/5 + dd + 77 + 5*(yyyy+(mm-14)/12 - & (yyyy+(mm-14)/12)/100*100)/4 + (yyyy+(mm-14)/12)/400 - & (yyyy+(mm-14)/12)/100*2, 7) RETURN END FUNCTION izlr SUBROUTINE calend(yyyy, ddd, mm, dd) !=============CALEND WHEN GIVEN A VALID YEAR, YYYY, AND DAY OF THE YEAR, DDD, ! RETURNS THE MONTH, MM, AND DAY OF THE MONTH, DD. ! SEE ACM ALGORITHM 398, TABLELESS DATE CONVERSION, BY ! DICK STONE, CACM 13(10):621. INTEGER, INTENT(IN) :: yyyy INTEGER, INTENT(IN) :: ddd INTEGER, INTENT(OUT) :: mm INTEGER, INTENT(OUT) :: dd INTEGER :: t t = 0 IF(MOD(yyyy, 4) == 0) t = 1 !-----------THE FOLLOWING STATEMENT IS NECESSARY IF YYYY IS < 1900 OR > 2100. IF(MOD(yyyy, 400) /= 0 .AND. MOD(yyyy, 100) == 0) t = 0 dd = ddd IF(ddd > 59+t) dd = dd + 2 - t mm = ((dd+91)*100)/3055 dd = (dd+91) - (mm*3055)/100 mm = mm - 2 !----------MM WILL BE CORRECT IFF DDD IS CORRECT FOR YYYY. IF(mm >= 1 .AND. mm <= 12) RETURN WRITE(*,1) ddd 1 FORMAT('0\$\$\$CALEND: DAY OF THE YEAR INPUT =', i11, ' IS OUT OF RANGE.') STOP END SUBROUTINE calend SUBROUTINE cdate(jd, yyyy, mm, dd) !=======GIVEN A JULIAN DAY NUMBER, NNNNNNNN, YYYY,MM,DD ARE RETURNED AS THE ! CALENDAR DATE. JD = NNNNNNNN IS THE JULIAN DATE FROM AN EPOCH ! IN THE VERY DISTANT PAST. SEE CACM 1968 11(10):657, ! LETTER TO THE EDITOR BY FLIEGEL AND VAN FLANDERN. ! EXAMPLE CALL CDATE(2440588, YYYY, MM, DD) RETURNS 1970 1 1 . INTEGER, INTENT(IN) :: jd INTEGER, INTENT(OUT) :: yyyy INTEGER, INTENT(OUT) :: mm INTEGER, INTENT(OUT) :: dd INTEGER :: l, n l = jd + 68569 n = 4*l/146097 l = l - (146097*n + 3)/4 yyyy = 4000*(l+1)/1461001 l = l - 1461*yyyy/4 + 31 mm = 80*l/2447 dd = l - 2447*mm/80 l = mm/11 mm = mm + 2 - 12*l yyyy = 100*(n-49) + yyyy + l RETURN END SUBROUTINE cdate SUBROUTINE daysub(jd, yyyy, mm, dd, wd, ddd) !========GIVEN JD, A JULIAN DAY # (SEE ASF JD), THIS ROUTINE CALCULATES DD, ! THE DAY NUMBER OF THE MONTH; MM, THE MONTH NUMBER; YYYY THE YEAR; ! WD THE WEEKDAY NUMBER, AND DDD THE DAY NUMBER OF THE YEAR. ! EXAMPLE: CALL DAYSUB(2440588, YYYY, MM, DD, WD, DDD) YIELDS 1970 1 1 4 1. INTEGER, INTENT(IN) :: jd INTEGER, INTENT(OUT) :: yyyy INTEGER, INTENT(OUT) :: mm INTEGER, INTENT(OUT) :: dd INTEGER, INTENT(OUT) :: wd INTEGER, INTENT(OUT) :: ddd CALL cdate(jd, yyyy, mm, dd) wd = izlr(yyyy, mm, dd) ddd = iday(yyyy, mm, dd) RETURN END SUBROUTINE daysub FUNCTION jd(yyyy, mm, dd) RESULT(ival) INTEGER, INTENT(IN) :: yyyy INTEGER, INTENT(IN) :: mm INTEGER, INTENT(IN) :: dd INTEGER :: ival ! DATE ROUTINE JD(YYYY, MM, DD) CONVERTS CALENDER DATE TO ! JULIAN DATE. SEE CACM 1968 11(10):657, LETTER TO THE ! EDITOR BY HENRY F. FLIEGEL AND THOMAS C. VAN FLANDERN. ! EXAMPLE JD(1970, 1, 1) = 2440588 ival = dd - 32075 + 1461*(yyyy+4800+(mm-14)/12)/4 + & 367*(mm-2-((mm-14)/12)*12)/12 - 3*((yyyy+4900+(mm-14)/12)/100)/4 RETURN END FUNCTION jd FUNCTION ndays(mm1, dd1, yyyy1, mm2, dd2, yyyy2) RESULT(ival) INTEGER, INTENT(IN) :: mm1 INTEGER, INTENT(IN) :: dd1 INTEGER, INTENT(IN) :: yyyy1 INTEGER, INTENT(IN) :: mm2 INTEGER, INTENT(IN) :: dd2 INTEGER, INTENT(IN) :: yyyy2 INTEGER :: ival !==============NDAYS IS RETURNED AS THE NUMBER OF DAYS BETWEEN TWO ! DATES; THAT IS MM1/DD1/YYYY1 MINUS MM2/DD2/YYYY2, ! WHERE DATEI AND DATEJ HAVE ELEMENTS MM, DD, YYYY. !-------NDAYS WILL BE POSITIVE IFF DATE1 IS MORE RECENT THAN DATE2. ival = jd(yyyy1, mm1, dd1) - jd(yyyy2, mm2, dd2) RETURN END FUNCTION ndays SUBROUTINE date_stamp( string, want_day, short ) CHARACTER (LEN=*), INTENT(OUT) :: string LOGICAL, INTENT(IN), OPTIONAL :: want_day, short ! Returns the current date as a character string ! e.g. ! want_day short string ! .TRUE. .TRUE. Thursday, 23 Dec 1999 ! .TRUE. .FALSE. Thursday, 23 December 1999 <- default ! .FALSE. .TRUE. 23 Dec 1999 ! .FALSE. .FALSE. 23 December 1999 INTEGER :: val(8), pos LOGICAL :: want_d, sh CHARACTER (LEN=9) :: day(0:6) = (/ 'Sunday ', 'Monday ', 'Tuesday ', & 'Wednesday', 'Thursday ', 'Friday ', 'Saturday ' /) CHARACTER (LEN=9) :: month(1:12) = (/ 'January ', 'February ', 'March ', & 'April ', 'May ', 'June ', 'July ', & 'August ', 'September', 'October ', 'November ', & 'December ' /) want_d = .TRUE. IF (PRESENT(want_day)) want_d = want_day sh = .FALSE. IF (PRESENT(short)) sh = short CALL DATE_AND_TIME(VALUES=val) IF (want_d) THEN pos = izlr(val(1), val(2), val(3)) string = TRIM( day(pos) ) // ',' pos = LEN_TRIM( string ) + 2 ELSE pos = 1 string = ' ' END IF WRITE(string(pos:pos+1), '(i2)') val(3) IF (sh) THEN string(pos+3:pos+5) = month(val(2))(1:3) pos = pos + 7 ELSE string(pos+3:) = month(val(2)) pos = LEN_TRIM( string ) + 2 END IF WRITE( string(pos:pos+3), '(i4)') val(1) RETURN END SUBROUTINE date_stamp END MODULE date_sub PROGRAM test_datesub !======DATESUB.FOR with Sample Drivers. USE date_sub IMPLICIT NONE INTEGER :: yyyy, mm, dd, wd, ddd, mma, dda, ndiff, val(8) CHARACTER (LEN=50) :: message ! Test date_stamp message = ' date_stamp = ' CALL date_stamp( message(15:) ) WRITE(*, '(a)') message message = ' date_stamp = ' CALL date_stamp( message(15:), want_day=.FALSE.) WRITE(*, '(a)') message message = ' date_stamp = ' CALL date_stamp( message(15:), short=.TRUE.) WRITE(*, '(a)') message message = ' date_stamp = ' CALL date_stamp( message(15:), want_day=.FALSE., short=.TRUE.) WRITE(*, '(a)') message ! Is this a leap year? I.e. is 12/31/yyyy the 366th day of the year? CALL DATE_AND_TIME(VALUES=val) yyyy = val(1) IF(iday(yyyy, 12, 31) == 366) THEN WRITE(*,*) yyyy, ' is a Leap Year' ELSE WRITE(*,*) yyyy, ' is not a Leap Year' END IF ! DAYSUB SHOULD RETURN: 1970, 1, 1, 4, 1 CALL daysub(jd(1970, 1, 1), yyyy, mm, dd, wd, ddd) IF(yyyy /= 1970 .OR. mm /= 1 .OR. dd /= 1 .OR. wd /= 4 .OR. ddd /= 1) THEN WRITE(*,*) 'DAYSUB Failed; YYYY, MM, DD, WD, DDD = ', yyyy, mm, dd, wd, ddd STOP END IF ! DIFFERENCE BETWEEN TO SAME MONTHS AND DAYS OVER 1 LEAP YEAR IS 366. ndiff = ndays(5, 22, 1984, 5, 22, 1983) IF(ndiff /= 366) THEN WRITE(*,*) 'NDAYS FAILED; NDIFF = ', ndiff ELSE ! RECOVER MONTH AND DAY FROM YEAR AND DAY NUMBER. CALL calend(yyyy, ddd, mma, dda) IF(mma /= 1 .AND. dda /= 1) THEN WRITE(*,*) 'CALEND FAILED; MMA, DDA = ', mma, dda ELSE WRITE(*,*) '** DATE MANIPULATION SUBROUTINES SIMPLE TEST OK.' END IF END IF STOP END PROGRAM test_datesub