!*********************************************************************************************************************************** ! ! F E D H O L I D A Y S ! ! Program: FEDHOLIDAYS ! ! Programmer: David G. Simpson ! Laurel, Maryland ! ! Date: December 6, 2005 ! ! Language: Fortran-90 ! ! Version: 1.00d (November 14, 2007) ! ! Description: Computes the dates of federal holidays. ! ! Files: Source files: ! ! fedholidays.f90 Main program ! ! Syntax: fedholidays for current year ! or fedholidays for specified year ! ! Note: This program uses one non-standard subroutine: GETCL returns the command line string. ! ! This version creates a linked list of holidays, so that it can handle the possibility of more than one holiday ! occuring on a given date. The linked list is printed in sorted order at the end of the program. ! ! Throughout the program, days of the week are numbered so that 0=Sunday, 1=Monday, 2=Tuesday, ..., 6=Saturday. ! ! The date of Election Day is also given, although it is not actually a federal holiday. ! !*********************************************************************************************************************************** PROGRAM FEDHOLIDAYS IMPLICIT NONE CHARACTER(LEN=9), DIMENSION(12), PARAMETER :: MONTH_NAME = (/ & 'January ', 'February ', 'March ', 'April ', 'May ', 'June ', & 'July ', 'August ', 'September', 'October ', 'November ', 'December ' /) CHARACTER(LEN=9), DIMENSION(0:6), PARAMETER :: DOW_NAME = (/ & 'Sunday ', 'Monday ', 'Tuesday ', 'Wednesday', 'Thursday ', 'Friday ', 'Saturday ' /) CHARACTER(LEN=80) :: CL CHARACTER(LEN=10) :: TIME, DATE, ZONE INTEGER :: DT(8) INTEGER :: I, IERR, YEAR, MONTH, DOM, DOY, DOW LOGICAL :: LEAP_FLAG LOGICAL :: LEAP INTEGER :: GREG2DOW TYPE :: HOLIDAY_TYPE CHARACTER(30) :: HNAME INTEGER :: MONTH INTEGER :: DOM INTEGER :: DOW INTEGER :: DOY INTEGER :: PRINT_YEAR TYPE (HOLIDAY_TYPE), POINTER :: NEXT END TYPE HOLIDAY_TYPE TYPE (HOLIDAY_TYPE), POINTER :: FRONT, REAR, NODE_PTR !----------------------------------------------------------------------------------------------------------------------------------- CALL GETCL (CL) ! get command line string IF (LEN_TRIM(CL) .GT. 0) THEN ! if command line parameter length > 0.. READ (UNIT=CL, FMT=*, IOSTAT=IERR) YEAR ! ..then assume year only input IF (IERR .NE. 0) THEN ! check for input error WRITE (UNIT=*, FMT='(A)') ' Input error.' STOP END IF ELSE ! if no command line parameter.. CALL DATE_AND_TIME (DATE, TIME, ZONE, DT) ! ..then get current date YEAR = DT(1) ! use current year END IF LEAP_FLAG = LEAP (YEAR) ! ! Place holiday information into HOLIDAY array. ! CALL GREG2DOY (LEAP_FLAG, YEAR, 1, 1, DOY, DOW) ! New Year's Day (Jan. 1) ALLOCATE (FRONT) REAR => FRONT REAR%HNAME = "New Year's Day .............. " IF (DOW .EQ. 0) THEN ! if Sunday, then observed on Monday REAR%MONTH = 1 REAR%DOM = 2 REAR%DOW = 1 REAR%DOY = 2 REAR%PRINT_YEAR = 0 ELSE IF (DOW .EQ. 6) THEN ! if on Saturday, then observed on Friday REAR%MONTH = 12 REAR%DOM = 31 REAR%DOW = 5 IF (LEAP(YEAR-1)) THEN REAR%DOY = 366 ELSE REAR%DOY = 365 END IF REAR%PRINT_YEAR = YEAR-1 ELSE REAR%MONTH = 1 REAR%DOM = 1 REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 END IF IF (LEAP(YEAR-1)) THEN ! Inauguration Day (Jan. 20) CALL GREG2DOY (LEAP_FLAG, YEAR, 1, 20, DOY, DOW) IF (DOW .GE. 1 .AND. DOW .LE. 5) THEN ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Inauguration Day ............ " REAR%MONTH = 1 REAR%DOM = 20 REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 END IF END IF CALL DOW2DOY (LEAP_FLAG, YEAR, 1, 1, 3, DOY, DOM) ! Martin Luther King Day (3rd Monday in Jan.) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Martin Luther King Day ...... " REAR%MONTH = 1 REAR%DOM = DOM REAR%DOW = 1 REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL DOW2DOY (LEAP_FLAG, YEAR, 2, 1, 3, DOY, DOM) ! Washington's Birthday (3rd Monday in Feb.) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Washington's Birthday ....... " REAR%MONTH = 2 REAR%DOM = DOM REAR%DOW = 1 REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL DOW2DOY (LEAP_FLAG, YEAR, 5, 1, 9, DOY, DOM) ! Memorial Day (last Monday in May) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Memorial Day ................ " REAR%MONTH = 5 REAR%DOM = DOM REAR%DOW = 1 REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL GREG2DOY (LEAP_FLAG, YEAR, 7, 4, DOY, DOW) ! Independence Day (July 4) IF (DOW .EQ. 0) THEN ! if Sunday, then observed on Monday DOM = 5 DOW = 1 ELSE IF (DOW .EQ. 6) THEN ! if Saturday, then observed on Friday DOM = 3 DOW = 5 ELSE DOM = 4 END IF ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Independence Day ............ " REAR%MONTH = 7 REAR%DOM = DOM REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL DOW2DOY (LEAP_FLAG, YEAR, 9, 1, 1, DOY, DOM) ! Labor Day (1st Monday in Sept.) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Labor Day ................... " REAR%MONTH = 9 REAR%DOM = DOM REAR%DOW = 1 REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL DOW2DOY (LEAP_FLAG, YEAR, 10, 1, 2, DOY, DOM) ! Columbus Day (2nd Monday in October) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Columbus Day ................ " REAR%MONTH = 10 REAR%DOM = DOM REAR%DOW = 1 REAR%DOY = DOY REAR%PRINT_YEAR = 0 IF (MOD(YEAR,2) .EQ. 0) THEN ! Election Day (Tuesday after 1st Monday in Nov) DOW = GREG2DOW (YEAR, 11, 1) IF (DOW .LT. 2) THEN DOM = 3 - DOW ELSE DOM = 10 - DOW END IF CALL GREG2DOY (LEAP_FLAG, YEAR, 11, DOM, DOY, DOW) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Election Day ................ " REAR%MONTH = 11 REAR%DOM = DOM REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 END IF CALL GREG2DOY (LEAP_FLAG, YEAR, 11, 11, DOY, DOW) ! Veteran's Day (Nov. 11) IF (DOW .EQ. 0) THEN ! if Sunday, then observed on Monday DOM = 12 DOW = 1 ELSE IF (DOW .EQ. 6) THEN ! if Saturday, then observed on Friday DOM = 10 DOW = 5 ELSE DOM = 11 END IF ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Veteran's Day ............... " REAR%MONTH = 11 REAR%DOM = DOM REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL DOW2DOY (LEAP_FLAG, YEAR, 11, 4, 4, DOY, DOM) ! Thanksgiving Day (4th Thursday in Nov.) ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Thanksgiving Day ............ " REAR%MONTH = 11 REAR%DOM = DOM REAR%DOW = 4 REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL GREG2DOY (LEAP_FLAG, YEAR, 12, 25, DOY, DOW) ! Christmas (Dec. 25) IF (DOW .EQ. 0) THEN ! if Sunday, then observed on Monday DOM = 26 DOW = 1 ELSE IF (DOW .EQ. 6) THEN ! if Saturday, then observed on Friday DOM = 24 DOW = 5 ELSE DOM = 25 END IF ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "Christmas Day ............... " REAR%MONTH = 12 REAR%DOM = DOM REAR%DOW = DOW REAR%DOY = DOY REAR%PRINT_YEAR = 0 CALL GREG2DOY (LEAP_FLAG, YEAR+1, 1, 1, DOY, DOW) ! New Year's Day of next year (Jan. 1) IF (DOW .EQ. 6) THEN ! if Saturday, then observed on Friday MONTH = 12 DOM = 31 DOW = 5 ALLOCATE (REAR%NEXT) REAR => REAR%NEXT REAR%HNAME = "New Year's Day .............. " REAR%MONTH = 12 REAR%DOM = 31 REAR%DOW = 5 REAR%DOY = DOY IF (LEAP_FLAG) THEN REAR%DOY = 366 ELSE REAR%DOY = 365 END IF REAR%PRINT_YEAR = 0 END IF NULLIFY (REAR%NEXT) ! ! Print holiday list. ! WRITE (UNIT=*, FMT='()') NODE_PTR => FRONT DO WHILE (ASSOCIATED(NODE_PTR)) IF (NODE_PTR%PRINT_YEAR .EQ. 0) THEN WRITE (UNIT=*, FMT='(1X,A,I2)') NODE_PTR%HNAME // TRIM(DOW_NAME(NODE_PTR%DOW)) // & ', ' // TRIM(MONTH_NAME(NODE_PTR%MONTH)) // ' ', NODE_PTR%DOM ELSE WRITE (UNIT=*, FMT='(1X,A,I2,A,I4)') NODE_PTR%HNAME // TRIM(DOW_NAME(NODE_PTR%DOW)) // & ', ' // TRIM(MONTH_NAME(NODE_PTR%MONTH)) // ' ', NODE_PTR%DOM, ', ', NODE_PTR%PRINT_YEAR END IF NODE_PTR => NODE_PTR%NEXT END DO STOP END PROGRAM FEDHOLIDAYS !*********************************************************************************************************************************** ! GREG2DOY ! ! Return the day of year and day of week for a given calendar date. !*********************************************************************************************************************************** SUBROUTINE GREG2DOY (LEAP_FLAG, YEAR, MONTH, DOM, DOY, DOW) IMPLICIT NONE LOGICAL, INTENT(IN) :: LEAP_FLAG INTEGER, INTENT(IN) :: YEAR, MONTH, DOM INTEGER, INTENT(OUT) :: DOY, DOW INTEGER :: K INTEGER :: GREG2DOW IF (LEAP_FLAG) THEN K = 1 ELSE K = 2 END IF DOY = ((275*MONTH)/9) - K*((MONTH+9)/12) + DOM - 30 DOW = GREG2DOW (YEAR, MONTH, DOM) RETURN END SUBROUTINE GREG2DOY !*********************************************************************************************************************************** ! DOW2DOY ! ! Return the day of year and day of month for a given day of week (e.g. third Monday of November). ! Set NUM=9 on input for the last day (e.g. last Monday of November). !*********************************************************************************************************************************** SUBROUTINE DOW2DOY (LEAP_FLAG, YEAR, MONTH, DOW, NUM, DOY, DOM) IMPLICIT NONE LOGICAL, INTENT(IN) :: LEAP_FLAG INTEGER, INTENT(IN) :: YEAR, MONTH, DOW, NUM INTEGER, INTENT(OUT) :: DOY, DOM ! J F M A M J J A S O N D INTEGER, DIMENSION(12) :: DAYS_PER_MONTH = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) INTEGER :: CURRENT_DOW, I INTEGER :: GREG2DOW IF (LEAP_FLAG) DAYS_PER_MONTH(2) = 29 IF (NUM .EQ. 9) THEN DOM = DAYS_PER_MONTH(MONTH) DO I = 0, 6 CURRENT_DOW = GREG2DOW (YEAR, MONTH, DOM) IF (CURRENT_DOW .EQ. DOW) EXIT DOM = DOM - 1 END DO CALL GREG2DOY (LEAP_FLAG, YEAR, MONTH, DOM, DOY, CURRENT_DOW) ELSE DOM = 1 DO I = 0, 6 CURRENT_DOW = GREG2DOW (YEAR, MONTH, DOM) IF (CURRENT_DOW .EQ. DOW) EXIT DOM = DOM + 1 END DO DOM = DOM + 7*(NUM-1) CALL GREG2DOY (LEAP_FLAG, YEAR, MONTH, DOM, DOY, CURRENT_DOW) END IF RETURN END SUBROUTINE DOW2DOY !*********************************************************************************************************************************** ! EASTER ! ! Return the day of year, month, and day of month of Easter for the specified year. !*********************************************************************************************************************************** SUBROUTINE EASTER (LEAP_FLAG, YEAR, DOY, MONTH, DOM) IMPLICIT NONE LOGICAL, INTENT(IN) :: LEAP_FLAG INTEGER, INTENT(IN) :: YEAR INTEGER, INTENT(OUT) :: DOY, MONTH, DOM INTEGER :: A, B, C, D, E, F, G, H, I, K, L, M, N, P, T, DOW A = MOD(YEAR,19) B = YEAR/100 C = MOD(YEAR,100) D = B/4 E = MOD(B,4) F = (B+8)/25 G = (B-F+1)/3 H = MOD(19*A+B-D-G+15, 30) I = C/4 K = MOD(C,4) L = MOD(32+2*E+2*I-H-K, 7) M = (A+11*H+22*L)/451 T = H+L-7*M+114 N = T/31 P = MOD(T,31) MONTH = N DOM = P+1 CALL GREG2DOY (LEAP_FLAG, YEAR, MONTH, DOM, DOY, DOW) RETURN END SUBROUTINE EASTER !*********************************************************************************************************************************** ! DOY2GREG ! ! Return the month, day of month, and day of week corresponding to the given day of year. !*********************************************************************************************************************************** SUBROUTINE DOY2GREG (LEAP_FLAG, YEAR, DOY, MONTH, DOM, DOW) IMPLICIT NONE LOGICAL, INTENT(IN) :: LEAP_FLAG INTEGER, INTENT(IN) :: YEAR, DOY INTEGER, INTENT(OUT) :: MONTH, DOM, DOW INTEGER :: K INTEGER :: GREG2DOW IF (LEAP_FLAG) THEN ! set K based on calendar type K = 1 ELSE K = 2 END IF MONTH = INT(9.0D0*(K+DOY)/275.0D0 + 0.98D0) ! compute month IF (DOY .LT. 32) MONTH = 1 DOM = DOY - ((275*MONTH)/9) + K*((MONTH+9)/12) + 30 ! compute day of month DOW = GREG2DOW (YEAR, MONTH, DOM) RETURN END SUBROUTINE DOY2GREG !*********************************************************************************************************************************** ! GREG2DOW ! ! Return the day of week corresponding to a Gregorian calendar date. !*********************************************************************************************************************************** FUNCTION GREG2DOW (YEAR, MONTH, DOM) RESULT (DOW) IMPLICIT NONE INTEGER, INTENT(IN) :: YEAR, MONTH, DOM INTEGER :: DOW INTEGER :: Y, M, A, B DOUBLE PRECISION :: JD Y = YEAR M = MONTH IF (M .LE. 2) THEN Y = Y - 1 M = M + 12 END IF A = Y/100 B = 2 - A + A/4 JD = INT(365.25D0*(Y+4716)) + INT(30.6001D0*(M+1)) + DOM + B - 1524.5D0 DOW = MOD(NINT(JD+1.5D0), 7) RETURN END FUNCTION GREG2DOW !*********************************************************************************************************************************** ! LEAP - Determine whether a given year is a leap year. !*********************************************************************************************************************************** FUNCTION LEAP (YEAR) RESULT (LEAP_FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: YEAR LOGICAL :: LEAP_FLAG LEAP_FLAG = .FALSE. IF (MOD(YEAR,4) .EQ. 0) LEAP_FLAG = .TRUE. IF (MOD(YEAR,100) .EQ. 0) LEAP_FLAG = .FALSE. IF (MOD(YEAR,400) .EQ. 0) LEAP_FLAG = .TRUE. RETURN END FUNCTION LEAP