subroutine ch_cap ( c ) !*****************************************************************************80 ! !! CH_CAP capitalizes a single character. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none character c integer ( kind = 4 ) itemp itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine cws_to_jed_gps ( c, w, s, jed ) !*****************************************************************************80 ! !! CWS_TO_JED_GPS converts a GPS CWS date to a JED. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) C, integer ( kind = 4 ) W, real ( kind = 8 ) S, ! the GPS cycle/week/second date. ! ! Output, real ( kind = 8 ) JED, the corresponding Julian Ephemeris Date. ! implicit none integer ( kind = 4 ) c real ( kind = 8 ) d real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ) s integer ( kind = 4 ) w call epoch_to_jed_gps ( jed_epoch) d = real ( 7 * ( 1024 * c + w ), kind = 8 ) & + s / ( 24.0D+00 * 60.0D+00 * 60.0D+00 ) jed = jed_epoch + d return end subroutine cws_to_s_gps ( c, w, sec, s ) !*****************************************************************************80 ! !! CWS_TO_S_GPS writes a GPS CWS date into a string. ! ! Format: ! ! CC/WWWW/SSSSSS.SS GPS ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) C, integer ( kind = 4 ) W, real ( kind = 8 ) SEC, ! the GPS cycle/week/second date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none integer ( kind = 4 ) c character ( len = 25 ) s1 character ( len = 4 ) s2 character ( len = 9 ) s3 character ( len = * ) s real ( kind = 8 ) sec integer ( kind = 4 ) w call i4_to_s_left ( c, s1 ) call s_cat ( s1, '/', s1 ) call i4_to_s_zero ( w, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) write ( s3, '(f9.2)' ) sec s3 = adjustl ( s3 ) call s_cat ( s1, s3, s ) call s_cat ( s, ' GPS', s ) return end subroutine day_borrow_alexandrian ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_ALEXANDRIAN borrows days from months in an Alexandrian date. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) M, ! integer ( kind = 4 ) D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_alexandrian integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_alexandrian ( y, m ) days = month_length_alexandrian ( y, m ) d = d + days end do return end subroutine day_borrow_common ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_COMMON borrows days from months in a Common date. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) M, ! integer ( kind = 4 ) D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_common integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_common ( y, m ) days = month_length_common ( y, m ) d = d + days end do return end subroutine day_borrow_eg_civil ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_EG_CIVIL borrows days from months in an Egyptian Civil date. ! ! Modified: ! ! 24 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_eg_civil integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_eg_civil ( y, m ) days = month_length_eg_civil ( y, m ) d = d + days end do return end subroutine day_borrow_english ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_ENGLISH borrows days from months in an English date. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_english integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_english ( y, m ) days = month_length_english ( y, m ) d = d + days end do return end subroutine day_borrow_gregorian ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_GREGORIAN borrows days from months in a Gregorian date. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_gregorian integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_gregorian ( y, m ) days = month_length_gregorian ( y, m ) d = d + days end do return end subroutine day_borrow_hebrew ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_HEBREW borrows days from months in a Hebrew date. ! ! Modified: ! ! 24 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_hebrew integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_hebrew ( y, m ) days = month_length_hebrew ( y, m ) d = d + days end do return end subroutine day_borrow_islamic ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_ISLAMIC borrows days from months in an Islamic date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_islamic integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_islamic ( y, m ) days = month_length_islamic ( y, m ) d = d + days end do return end subroutine day_borrow_julian ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_JULIAN borrows days from months in a Julian date. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_julian integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_julian ( y, m ) days = month_length_julian ( y, m ) d = d + days end do return end subroutine day_borrow_republican ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_REPUBLICAN borrows days from months in a Republican date. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_republican integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_republican ( y, m ) days = month_length_republican ( y, m ) d = d + days end do return end subroutine day_borrow_roman ( y, m, d ) !*****************************************************************************80 ! !! DAY_BORROW_ROMAN borrows days from months in a Roman date. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, a year, month, and day ! representing a date. On input, D might be negative. On output, ! M should have decreased by one month, and D gone up by the ! number of days in the month we "cashed in". Y may be affected ! if the input value of M was 1. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_roman integer ( kind = 4 ) y do while ( d <= 0 ) m = m - 1 call month_borrow_roman ( y, m ) days = month_length_roman ( y, m ) d = d + days end do return end subroutine day_carry_alexandrian ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_ALEXANDRIAN carries days to months in an Alexandrian date. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_alexandrian integer ( kind = 4 ) y days = month_length_alexandrian ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_alexandrian ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_alexandrian ( y, m ) end do return end subroutine day_carry_common ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_COMMON carries days to months in a Common date. ! ! Algorithm: ! ! While ( number of days in M ) < D: ! decrease the day D by the number of days in the month M; ! increase M by 1; ! if necessary, adjust Y. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_common integer ( kind = 4 ) y ! ! If the date is in the transition month, deflate it, ! so we can perform ordinary arithmetic. ! call deflate_common ( y, m, d ) days = month_length_common ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_common ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_common ( y, m ) end do ! ! If the date is in the transition month, inflate it. ! call inflate_common ( y, m, d ) return end subroutine day_carry_eg_civil ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_EG_CIVIL carries days to months in an Egyptian Civil date. ! ! Modified: ! ! 28 August 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_eg_civil integer ( kind = 4 ) y days = month_length_eg_civil ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_eg_civil ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_eg_civil ( y, m ) end do return end subroutine day_carry_english ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_ENGLISH carries days to months in an English date. ! ! Algorithm: ! ! While ( number of days in M ) < D: ! decrease the day D by the number of days in the month M; ! increase M by 1; ! if necessary, adjust Y. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_english integer ( kind = 4 ) y ! ! If the date is in the transition month, deflate it, ! so we can perform ordinary arithmetic. ! call deflate_english ( y, m, d ) days = month_length_english ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_english ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_english ( y, m ) end do ! ! If the date is in the transition month, inflate it. ! call inflate_english ( y, m, d ) return end subroutine day_carry_gregorian ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_GREGORIAN carries days to months in a Gregorian date. ! ! Algorithm: ! ! While ( number of days in M ) < D: ! decrease the day D by the number of days in the month M; ! increase M by 1; ! if necessary, adjust Y. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_gregorian integer ( kind = 4 ) y days = month_length_gregorian ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_gregorian ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_gregorian ( y, m ) end do return end subroutine day_carry_hebrew ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_HEBREW carries days to months in a Hebrew date. ! ! Modified: ! ! 24 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_hebrew integer ( kind = 4 ) y days = month_length_hebrew ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_hebrew ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_hebrew ( y, m ) end do return end subroutine day_carry_islamic ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_ISLAMIC carries days to months in an Islamic date. ! ! Modified: ! ! 24 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_islamic integer ( kind = 4 ) y days = month_length_islamic ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_islamic ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_islamic ( y, m ) end do return end subroutine day_carry_julian ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_JULIAN carries days to months in a Julian date. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_julian integer ( kind = 4 ) y days = month_length_julian ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_julian ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_julian ( y, m ) end do return end subroutine day_carry_republican ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_REPUBLICAN carries days to months in a Republican date. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_republican integer ( kind = 4 ) y days = month_length_republican ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_republican ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_republican ( y, m ) end do return end subroutine day_carry_roman ( y, m, d ) !*****************************************************************************80 ! !! DAY_CARRY_ROMAN carries days to months in a Roman date. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! On output, D is between 1 and the number of days in M. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days integer ( kind = 4 ) m integer ( kind = 4 ) month_length_roman integer ( kind = 4 ) y days = month_length_roman ( y, m ) do while ( days < d ) d = d - days m = m + 1 days = month_length_roman ( y, m ) ! ! Make sure the month isn't too big. ! call month_carry_roman ( y, m ) end do return end subroutine day_list_common ( y1, m1, d1, y2, m2, d2 ) !*****************************************************************************80 ! !! DAY_LIST_COMMON prints a list of days between two dates. ! ! Discussion: ! ! Given the dates of September 25, 2005 and October 2, 2005, ! the routine should print out: ! ! Sun, Sep 25 2005 - ! Mon, Sep 26 2005 - ! Tue, Sep 27 2005 - ! Wed, Sep 28 2005 - ! Thu, Sep 29 2005 - ! Fri, Sep 30 2005 - ! Sat, Oct 01 2005 - ! Sun, Oct 02 2005 - ! ! Modified: ! ! 11 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, the first date. ! ! Input, integer Y2, integer M2, integer D2, the second date. ! implicit none character cmp integer ( kind = 4 ) d integer ( kind = 4 ) d1 integer ( kind = 4 ) d2 double precision f integer ( kind = 4 ) m character ( len = 3 ) m_name integer ( kind = 4 ) m1 integer ( kind = 4 ) m2 integer ( kind = 4 ) w character ( len = 3 ) w_name integer ( kind = 4 ) y integer ( kind = 4 ) y1 integer ( kind = 4 ) y2 y = y1 m = m1 d = d1 f = 0.0D+00 cmp = '<' do while ( cmp /= '>' ) call ymdf_to_weekday_common ( y, m, d, f, w ) call weekday_to_name_common3 ( w, w_name) call month_to_month_name_common3 ( m, m_name) write ( *, '(a3,'','',1x,a3,1x,i2,1x,i4,'' - '')' ) w_name, m_name, d, y call ymdf_next_common ( y, m, d, f, y, m, d, f ) call ymdf_compare ( y, m, d, f, y2, m2, d2, f, cmp ) end do return end function days_before_month_common ( y, m ) !*****************************************************************************80 ! !! DAYS_BEFORE_MONTH_COMMON returns the number of days before a Common month. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year in which the month occurred. ! ! Input, integer M, the number of the month. ! ! Output, integer DAYS_BEFORE_MONTH_COMMON, the number of days in the year ! before the first day of the given month. ! implicit none integer ( kind = 4 ) ierror integer ( kind = 4 ) m integer ( kind = 4 ) m2 integer ( kind = 4 ), parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer ( kind = 4 ) days_before_month_common integer ( kind = 4 ) y integer ( kind = 4 ) y2 logical year_is_leap_common ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_common ( y2, m2, ierror ) if ( ierror /= 0 ) then days_before_month_common = 0 return end if days_before_month_common = mdays ( m2 ) if ( 2 < m2 .and. year_is_leap_common ( y2 ) ) then days_before_month_common = days_before_month_common + 1 end if return end function days_before_month_gregorian ( y, m ) !*****************************************************************************80 ! !! DAYS_BEFORE_MONTH_GREGORIAN returns the number of days before a Gregorian month. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year in which the month occurred. ! ! Input, integer M, the number of the month. ! ! Output, integer DAYS_BEFORE_MONTH_GREGORIAN, the number of days in the year ! before the first day of the given month. ! implicit none integer ( kind = 4 ) ierror integer ( kind = 4 ) m integer ( kind = 4 ) m2 integer ( kind = 4 ), parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer ( kind = 4 ) days_before_month_gregorian integer ( kind = 4 ) y integer ( kind = 4 ) y2 logical year_is_leap_gregorian ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_gregorian ( y2, m2, ierror ) if ( ierror /= 0 ) then days_before_month_gregorian = 0 return end if days_before_month_gregorian = mdays ( m2 ) if ( 2 < m2 .and. year_is_leap_gregorian ( y2 ) ) then days_before_month_gregorian = days_before_month_gregorian + 1 end if return end function days_before_month_julian ( y, m ) !*****************************************************************************80 ! !! DAYS_BEFORE_MONTH_JULIAN returns the number of days before a Julian month. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year in which the month occurred. ! ! Input, integer M, the number of the month. ! ! Output, integer DAYS_BEFORE_MONTH_JULIAN, the number of days in the year ! before the first day of the given month. ! implicit none integer ( kind = 4 ) ierror integer ( kind = 4 ) m integer ( kind = 4 ) m2 integer ( kind = 4 ), parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer ( kind = 4 ) days_before_month_julian integer ( kind = 4 ) y integer ( kind = 4 ) y2 logical year_is_leap_julian ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_julian ( y2, m2, ierror ) if ( ierror /= 0 ) then days_before_month_julian = 0 return end if days_before_month_julian = mdays ( m2 ) if ( 2 < m2 .and. year_is_leap_julian ( y2 ) ) then days_before_month_julian = days_before_month_julian + 1 end if return end subroutine deflate_common ( y, m, d ) !*****************************************************************************80 ! !! DEFLATE_COMMON "deflates" dates in the Common Calendar transition month. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) m integer ( kind = 4 ) y if ( y == 1582 ) then if ( m == 10 ) then if ( 15 <= d ) then d = d - 10 end if end if end if return end subroutine deflate_english ( y, m, d ) !*****************************************************************************80 ! !! DEFLATE_ENGLISH "deflates" dates in the English Calendar transition month. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) m integer ( kind = 4 ) y if ( y == 1752 ) then if ( m == 9 ) then if ( 14 <= d ) then d = d - 11 end if end if end if return end subroutine digit_to_ch ( digit, c ) !*****************************************************************************80 ! !! DIGIT_TO_CH returns the character representation of a decimal digit. ! ! Example: ! ! DIGIT C ! ----- --- ! 0 '0' ! 1 '1' ! ... ... ! 9 '9' ! 17 '*' ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIGIT, the digit value between 0 and 9. ! ! Output, character C, the corresponding character, or '*' if DIGIT ! was illegal. ! implicit none character c integer ( kind = 4 ) digit if ( 0 <= digit .and. digit <= 9 ) then c = char ( digit + 48 ) else c = '*' end if return end subroutine easter_ds ( y, m, d ) !*****************************************************************************80 ! !! EASTER_DS computes the month and day of Easter for a Common year. ! ! Example: ! ! Input: ! ! Y = 2000 ! ! Output: ! ! M = 4 ! D = 23 ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Peter Duffett-Smith, ! Practical Astronomy With Your Calculator, ! Third Edition, ! Cambridge University Press, 1996, ! ISBN: 0-521-35699-7, ! LC: QB62.5.D83. ! ! Parameters: ! ! Input, integer Y, the year, which must be 1583 or greater. ! (The formula is only valid for years after the Gregorian calendar ! was adopted.) ! ! Output, integer M, D, the month and day of Easter. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) dd integer ( kind = 4 ) e integer ( kind = 4 ) f integer ( kind = 4 ) g integer ( kind = 4 ) h integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) m integer ( kind = 4 ) mm integer ( kind = 4 ) y if ( y <= 0 ) then m = -1 d = -1 return end if call year_to_golden_number ( y, a ) a = a - 1 b = y / 100 c = mod ( y, 100 ) dd = b / 4 e = mod ( b, 4 ) f = ( b + 8 ) / 25 g = ( b - f + 1 ) / 3 h = mod ( 19 * a + b - dd - g + 15, 30 ) i = c / 4 k = mod ( c, 4 ) l = mod ( 32 + 2 * e + 2 * i - h - k, 7 ) mm = ( a + 11 * h + 22 * l ) / 451 m = ( h + l - 7 * mm + 114 ) / 31 d = mod ( h + l - 7 * mm + 114, 31 ) + 1 return end subroutine easter_egr ( y, m, d ) !*****************************************************************************80 ! !! EASTER_EGR computes the month and day of Easter for a Common year. ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm O, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 375. ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) e integer ( kind = 4 ) g integer ( kind = 4 ) h integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) p integer ( kind = 4 ) q integer ( kind = 4 ) r integer ( kind = 4 ) s integer ( kind = 4 ) u integer ( kind = 4 ) vp integer ( kind = 4 ) y if ( y <= 0 ) then m = -1 d = -1 return end if p = y + ( y / 4 ) - ( y / 100 ) + ( y / 400 ) - 1 n = 7 - mod ( p, 7 ) h = y / 100 q = h - h / 4 g = 1 + mod ( y, 19 ) e = mod ( 57 + 11 * g - q + ( h - ( h - 17 ) / 25 ) / 3, 30 ) u = mod ( 53 - e, 30 ) vp = ( g - 1 + 11 * u ) / 319 r = 22 + u - vp c = i4_wrap ( r + 3, 1, 7 ) s = r + mod ( 7 + n - c, 7 ) m = 3 + ( s / 32 ) d = i4_wrap ( s, 1, 31 ) return end subroutine easter_egr2 ( y, m, d ) !*****************************************************************************80 ! !! EASTER_EGR2 computes the month and day of Easter for a Common year. ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm P, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 376. ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) e integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) m integer ( kind = 4 ) s integer ( kind = 4 ) y if ( y <= 0 ) then m = -1 d = -1 return end if a = y / 100 b = a - ( a / 4 ) c = mod ( y, 19 ) d = mod ( 15 + 19 * c + b - ( a - ( a - 17 ) / 25 ) / 3, 30 ) e = d - ( c + 11 * d ) / 319 s = 22 + e + mod ( 140004 - y - ( y / 4 ) + b - e, 7 ) m = 3 + ( s / 32 ) d = i4_wrap ( s, 1, 31 ) return end subroutine easter_julian ( y, m, d ) !*****************************************************************************80 ! !! EASTER_JULIAN computes the date of Easter in the Julian calendar. ! ! Discussion: ! ! This computation for the date of Easter uses the Dionysian ! canon that applied to the Julian calendar. The determination ! of the date of Easter changed at the same time that the calendar ! was modified to use the Gregorian system. ! ! Modified: ! ! 31 March 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm M, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 365. ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of the Julian calendar on ! which Easter occurs. ! implicit none integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) e integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) p integer ( kind = 4 ) r integer ( kind = 4 ) s integer ( kind = 4 ) y if ( y <= 0 ) then m = -1 d = -1 return end if p = y + ( y / 4 ) + 4 n = 7 - mod ( p, 7 ) call year_to_epact_julian ( y, e ) r = 22 + mod ( 53 - e, 30 ) c = i4_wrap ( r + 3, 1, 7 ) s = r + mod ( 7 + n - c, 7 ) m = 3 + ( s / 32 ) ! ! Use wrapping so that 1 <= D <= 31. ! d = i4_wrap ( s, 1, 31 ) return end subroutine easter_julian2 ( y, m, d ) !*****************************************************************************80 ! !! EASTER_JULIAN2 computes the date of Easter in the Julian calendar. ! ! Discussion: ! ! This computation for the date of Easter uses the Dionysian ! canon that applied to the Julian calendar. The determination ! of the date of Easter changed at the same time that the calendar ! was modified to use the Gregorian system. ! ! Modified: ! ! 31 March 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm N, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 365. ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of the Julian calendar ! on which Easter occurs. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) d integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) m integer ( kind = 4 ) s integer ( kind = 4 ) y if ( y <= 0 ) then m = -1 d = -1 return end if call year_to_golden_number ( y, a ) a = a - 1 b = 22 + mod ( 225 - 11 * a, 30 ) s = b + mod ( 56 + 6 * y - ( y / 4 ) - b, 7 ) m = 3 + ( s / 32 ) ! ! Use wrapping to ensure that 1 <= D <= 31. ! d = i4_wrap ( s, 1, 31 ) return end subroutine easter_knuth ( y, m, d ) !*****************************************************************************80 ! !! EASTER_KNUTH computes the month and day of Easter for a Common year. ! ! Discussion: ! ! Knuth attributes the algorithm to Aloysius Lilius and Christopher Clavius ! in the late 16th century. The algorithm is for use with the Gregorian ! calendar. ! ! Example: ! ! Input: ! ! Y = 2000 ! ! Output: ! ! M = 4 ! D = 23 ! ! Modified: ! ! 05 April 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1: Fundamental Algorithms, ! Addison Wesley, 1968, pages 155-156. ! ! Donald Knuth, ! The Calculation of Easter, ! Communications of the ACM, ! Volume 5, Number 4, April 1962, pages 209-210. ! ! Thomas O'Beirne, ! Puzzles and Paradoxes, ! Oxford University Press, 1965, chapter 10. ! ! Parameters: ! ! Input, integer Y, the year, which must be 1583 or greater. ! (The formula is only valid for years after the Gregorian calendar ! was adopted.) ! ! Output, integer M, D, the month and day of Easter. ! implicit none integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) dd integer ( kind = 4 ) e integer ( kind = 4 ) g integer ( kind = 4 ) i4_modp integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) x integer ( kind = 4 ) y integer ( kind = 4 ) z if ( y <= 0 ) then m = -1 d = -1 return end if ! ! E1: Set the golden number of the year in the 19-year Metonic cycle. ! call year_to_golden_number ( y, g ) ! ! E2: Set the century. ! c = ( y / 100 ) + 1 ! ! E3: Corrections. ! X is the number of years divisible by 100 in which leap year was dropped. ! Z is a special correction to synchronize Easter with the moon's orbit. ! x = ( 3 * c / 4 ) - 12 z = ( 8 * c + 5 ) / 25 - 5 ! ! E4: Find Sunday. ! dd = ( 5 * y / 4 ) - x - 10 ! ! E5: Epact ! e = i4_modp ( 11 * g + 20 + z - x, 30 ) if ( ( e == 25 .and. 11 < g ) .or. ( e == 24 ) ) then e = e + 1 end if ! ! E6: Find the full moon. ! n = 44 - e if ( n < 21 ) then n = n + 30 end if ! ! E7: Advance to Sunday. ! n = n + 7 - mod ( dd + n, 7 ) ! ! E8: Get month. ! if ( 31 < n ) then d = n - 31 m = 4 else d = n m = 3 end if return end subroutine easter_stewart ( y, m, d ) !*****************************************************************************80 ! !! EASTER_STEWART computes the month and day of Easter for a Gregorian year. ! ! Example: ! ! Y = 2001 ! ! A = 6 ! B = 20 ! C = 1 ! DD = 5 ! E = 0 ! G = 6 ! H = 18 ! MM = 0 ! J = 0 ! K = 1 ! L = 6 ! M = 4 ! D = 15 ! ! Modified: ! ! 18 February 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Thomas O'Beirne, ! Puzzles and Paradoxes, ! Oxford University Press, 1965. ! ! Ian Stewart, ! Easter is a Quasicrystal, ! Scientific American, ! March 2001, pages 80-83. ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) dd integer ( kind = 4 ) e integer ( kind = 4 ) g integer ( kind = 4 ) h integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) m integer ( kind = 4 ) mm integer ( kind = 4 ) y a = mod ( y, 19 ) b = y / 100 c = mod ( y, 100 ) dd = b / 4 e = mod ( b, 4 ) g = ( 8 * b + 13 ) / 25 h = mod ( 19 * a + b - dd - g + 15, 30 ) mm = ( a + 11 * h ) / 319 j = c / 4 k = mod ( c, 4 ) l = mod ( 2 * e + 2 * j - k - h + mm + 32, 7 ) m = ( h - mm + l + 90 ) / 25 d = mod ( h - mm + l + m + 19 , 32 ) return end subroutine epoch_to_jed_akbar ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_AKBAR returns the epoch of the Akbar calendar as a JED. ! ! Modified: ! ! 11 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2289425.5D+00 return end subroutine epoch_to_jed_alexandrian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ALEXANDRIAN returns the epoch of the Alexandrian calendar as a JED. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1713262.5D+00 return end subroutine epoch_to_jed_armenian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ARMENIAN returns the epoch of the Armenian calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1922867.5D+00 return end subroutine epoch_to_jed_bahai ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_BAHAI returns the epoch of the Bahai calendar as a JED. ! ! Modified: ! ! 10 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2394646.5D+00 return end subroutine epoch_to_jed_bessel ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_BESSEL returns the epoch of the Bessel calendar as a JED. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2415020.31352D+00 return end subroutine epoch_to_jed_chinese ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_CHINESE returns the epoch of the Chinese calendar as a JED. ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 758325.5D+00 return end subroutine epoch_to_jed_common ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_COMMON returns the epoch of the Common calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1721423.5D+00 return end subroutine epoch_to_jed_coptic ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_COPTIC returns the epoch of the Coptic calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1825029.5D+00 return end subroutine epoch_to_jed_deccan ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_DECCAN returns the epoch of the Fasli Deccan calendar as a JED. ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1936747.5D+00 return end subroutine epoch_to_jed_eg_civil ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_EG_CIVIL returns the epoch of the Egyptian Civil calendar as a JED. ! ! Modified: ! ! 08 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1448637.5D+00 return end subroutine epoch_to_jed_eg_lunar ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_EG_LUNAR returns the epoch of the Egyptian Lunar calendar as a JED. ! ! Discussion: ! ! This is just a fake value, making the Egyptian Lunar calendar start ! at the same data as the Egyptian Civil calendar. ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1448637.5D+00 return end subroutine epoch_to_jed_english ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ENGLISH returns the epoch of the English calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1721423.5D+00 return end subroutine epoch_to_jed_ethiopian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ETHIOPIAN returns the epoch of the Ethiopian calendar as a JED. ! ! Modified: ! ! 10 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1724220.5D+00 return end subroutine epoch_to_jed_gps ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_GPS returns the epoch of the GPS calendar as a JED. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2444244.5D+00 return end subroutine epoch_to_jed_greek ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_GREEK returns the epoch of the Greek calendar as a JED. ! ! Discussion: ! ! The Greek Olympiad calendar began on 9 July 776 BC. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1438178.5D+00 return end subroutine epoch_to_jed_gregorian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_GREGORIAN returns the epoch of the Gregorian calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1721425.5D+00 return end subroutine epoch_to_jed_hebrew ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_HEBREW returns the epoch of the Hebrew calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 347998.5D+00 return end subroutine epoch_to_jed_hindu_lunar ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_HINDU_LUNAR returns the epoch of the Hindu lunar calendar as a JED. ! ! Modified: ! ! 11 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1741959.5D+00 return end subroutine epoch_to_jed_hindu_solar ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_HINDU_SOLAR returns the epoch of the Hindu solar calendar as a JED. ! ! Discussion: ! ! This is the beginning of the Kali Yuga era. ! ! Modified: ! ! 12 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 588465.75D+00 return end subroutine epoch_to_jed_islamic_a ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ISLAMIC_A returns the epoch of the Islamic A calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1948438.5D+00 return end subroutine epoch_to_jed_islamic_b ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ISLAMIC_B returns the epoch of the Islamic B calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1948439.5D+00 return end subroutine epoch_to_jed_jed ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_JED returns the epoch of the JED as a JED. ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! real ( kind = 8 ) jed jed = 0.0D+00 return end subroutine epoch_to_jed_jelali ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_JELALI returns the epoch of the Jelali calendar as a JED. ! ! Modified: ! ! 24 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2114872.5D+00 return end subroutine epoch_to_jed_julian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_JULIAN returns the epoch of the Julian calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1721423.5D+00 return end subroutine epoch_to_jed_khwarizmian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_KHWARIZMIAN returns the epoch of the Khwarizmian calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! real ( kind = 8 ) jed jed = 1952067.5D+00 return end subroutine epoch_to_jed_macedonian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_MACEDONIAN returns the epoch of the Macedonian calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1607708.5D+00 return end subroutine epoch_to_jed_mayan_long ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_MAYAN_LONG returns the epoch of the Mayan long count calendar as a JED. ! ! Modified: ! ! 10 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 584282.5D+00 return end subroutine epoch_to_jed_mjd ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_MJD returns the epoch of the MJD calendar as a JED. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2400000.5D+00 return end subroutine epoch_to_jed_nyt ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_NYT returns the epoch of the NYT calendar as a JED. ! ! Discussion: ! ! The "epoch" of the NYT calendar is the mythical date when issue "0" ! would have been printed, namely, a tad past midnight, 17 September 1851. ! ! Volume #1, Issue #1 was printed on 18 September 1851. ! ! Modified: ! ! 03 December 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2397382.5D+00 ! ! The following value is effectively the JED we are using for an ! epoch set to the nominal issue number 50,000. ! ! jed = 2449790.5D+00 return end subroutine epoch_to_jed_persian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_PERSIAN returns the epoch of the Persian calendar as a JED. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1952062.5D+00 return end subroutine epoch_to_jed_persian_solar ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_PERSIAN_SOLAR returns the epoch of the Persian solar calendar as a JED. ! ! Modified: ! ! 11 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1948320.5D+00 return end subroutine epoch_to_jed_rd ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_RD returns the epoch of the RD calendar as a JED. ! ! Modified: ! ! 05 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1721425.5D+00 return end subroutine epoch_to_jed_republican ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_REPUBLICAN returns the epoch of the Republican calendar as a JED. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2375839.5D+00 return end subroutine epoch_to_jed_roman ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ROMAN returns the epoch of the Roman calendar as a JED. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1446389.5D+00 return end subroutine epoch_to_jed_saka ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_SAKA returns the epoch of the Saka calendar as a JED. ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1749994.5D+00 return end subroutine epoch_to_jed_soor_san ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_SOOR_SAN returns the epoch of the Fasli Soor San calendar as a JED. ! ! Modified: ! ! 24 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1940351.5D+00 return end subroutine epoch_to_jed_syrian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_SYRIAN returns the epoch of the Syrian calendar as a JED. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1607738.5D+00 return end subroutine epoch_to_jed_unix ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_UNIX returns the epoch of the UNIX calendar as a JED. ! ! Discussion: ! ! The UNIX Epoch is taken to be the first second of 1 January 1970. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2440587.50D+00 return end subroutine epoch_to_jed_y2k ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_Y2K returns the epoch of the Y2K calendar as a JED. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 2451544.5D+00 return end subroutine epoch_to_jed_zoroastrian ( jed ) !*****************************************************************************80 ! !! EPOCH_TO_JED_ZOROASTRIAN returns the epoch of the Zoroastrian calendar as a JED. ! ! Modified: ! ! 12 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date of the epoch. ! implicit none real ( kind = 8 ) jed jed = 1862836.5D+00 return end subroutine frac_borrow_common ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_COMMON borrows fractions from days in a Common YMDF date. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_common ( y, m, d ) return end subroutine frac_borrow_english ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_ENGLISH borrows fractions from days in an English YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_english ( y, m, d ) return end subroutine frac_borrow_gregorian ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_GREGORIAN borrows fractions from days in a Gregorian YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_gregorian ( y, m, d ) return end subroutine frac_borrow_hebrew ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_HEBREW borrows fractions from days in a Hebrew YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_hebrew ( y, m, d ) return end subroutine frac_borrow_islamic ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_ISLAMIC borrows fractions from days in an Islamic YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_islamic ( y, m, d ) return end subroutine frac_borrow_julian ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_JULIAN borrows fractions from days in a Julian YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_julian ( y, m, d ) return end subroutine frac_borrow_republican ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_REPUBLICAN borrows fractions from days in a Republican YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_republican ( y, m, d ) return end subroutine frac_borrow_roman ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_BORROW_ROMAN borrows fractions from days in a Roman YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( f < 0.0D+00 ) f = f + 1.0D+00 d = d - 1 end do call day_borrow_roman ( y, m, d ) return end subroutine frac_carry_common ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_COMMON carries fractions to days in a Common YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! the YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_common ( y, m, d ) return end subroutine frac_carry_english ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_ENGLISH carries fractions to days in an English YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! the YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_english ( y, m, d ) return end subroutine frac_carry_gregorian ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_GREGORIAN carrys fractions from days in a Gregorian YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_gregorian ( y, m, d ) return end subroutine frac_carry_hebrew ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_HEBREW carrys fractions from days in a Hebrew YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_hebrew ( y, m, d ) return end subroutine frac_carry_islamic ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_ISLAMIC carrys fractions from days in an Islamic YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_islamic ( y, m, d ) return end subroutine frac_carry_julian ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_JULIAN carrys fractions from days in a Julian YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_julian ( y, m, d ) return end subroutine frac_carry_republican ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_REPUBLICAN carrys fractions from days in a Republican YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! a YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_republican ( y, m, d ) return end subroutine frac_carry_roman ( y, m, d, f ) !*****************************************************************************80 ! !! FRAC_CARRY_ROMAN carries fractions to days in a Roman YMDF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, real ( kind = 8 ) F, ! the YMDF date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) m integer ( kind = 4 ) y if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - real ( days, kind = 8 ) d = d + days call day_carry_roman ( y, m, d ) return end subroutine frac_to_hms ( f, h, m, s ) !*****************************************************************************80 ! !! FRAC_TO_HMS converts a fractional day into hours, minutes, seconds. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) F, a day fraction between 0.0 and 1.0. ! ! Output, integer H, integer M, integer S, the equivalent hours, minutes ! and seconds. ! implicit none real ( kind = 8 ) f real ( kind = 8 ) f2 integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) s f2 = f f2 = 24.0D+00 * f2 h = int ( f2 ) f2 = f2 - real ( h, kind = 8 ) f2 = 60.0D+00 * f2 m = int ( f2 ) f2 = f2 - real ( m, kind = 8 ) f2 = 60.0D+00 * f2 s = int ( f2 ) f2 = f2 - real ( s, kind = 8 ) return end subroutine frac_to_s ( f, s ) !*****************************************************************************80 ! !! FRAC_TO_S writes a positive fraction into a left justified character string. ! ! Modified: ! ! 05 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) F, the number to be written into the string. ! F should be between 0.0 and 1.0. ! ! Output, character ( len = * ) S, a representation of F. ! implicit none real ( kind = 8 ) f character ( len = * ) s character ( len = 14 ) s2 if ( f < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FRAC_TO_S - Fatal error!' write ( *, '(a)' ) ' The input fraction was negative:' write ( *, '(g14.6)' ) f stop else if ( 1.0D+00 <= f ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FRAC_TO_S - Fatal error!' write ( *, '(a)' ) ' The input fraction was 1 or more:' write ( *, '(g14.6)' ) f stop end if write ( s2, '(f11.10)' ) f s = s2 return end subroutine hms_to_s ( h, n, second, s ) !*****************************************************************************80 ! !! HMS_TO_S "prints" an HMS date into a string. ! ! Format: ! ! HH:MM:SS ! ! Modified: ! ! 14 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer H, N, SECOND, the HMS date. ! ! Output, character ( len = * ) S, contains a representation of the date. ! implicit none integer ( kind = 4 ) h integer ( kind = 4 ) n integer ( kind = 4 ) second character ( len = * ) s character ( len = 8 ) s1 call i4_to_s_zero ( h, s1(1:2) ) s1(3:3) = ':' call i4_to_s_zero ( n, s1(4:5) ) s1(6:6) = ':' call i4_to_s_zero ( second, s1(7:8) ) s = s1 return end subroutine hour_borrow_common ( y, m, d, h ) !*****************************************************************************80 ! !! HOUR_BORROW_COMMON "borrows" a day of hours. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, the year, month, day ! and hour of the date. The value of H is presumably negative, and ! so hours will be "borrowed" to make H positive. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( h <= 0 ) h = h + 24 d = d - 1 call day_borrow_common ( y, m, d ) end do return end subroutine hour_carry_common ( y, m, d, h ) !*****************************************************************************80 ! !! HOUR_CARRY_COMMON is given a YMDH date, and carries hours to days. ! ! Algorithm: ! ! While 24 < H: ! ! decrease H by the number of hours in a day; ! increase D by 1; ! if necessary, adjust M and Y. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, the year, month, day ! and hour of the date. On input, H is presumably 24 or greater. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) y do while ( 24 < h ) h = h - 24 d = d + 1 call day_carry_common ( y, m, d ) end do return end function i4_modp ( i, j ) !*****************************************************************************80 ! !! I4_MODP returns the positive remainder when I is divided by J. ! ! Formula: ! ! NREM = I4_MODP ( I, J ) ! NMULT = ( I - NREM ) / J ! ! I = J * NMULT + NREM ! ! Examples: ! ! I J NMULT NREM Factorization ! ! 107 50 2 7 107 = 2 * 50 + 7 ! 107 -50 -2 7 107 = -2 * -50 + 7 ! -107 50 -3 43 -107 = -3 * 50 + 43 ! -107 -50 3 43 -107 = 3 * -50 + 43 ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the number to be divided. ! ! Input, integer J, the number that divides I. ! ! Output, integer I4_MODP, the positive remainder when I is divided by J. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) i4_modp if ( j == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4_MODP - Fatal error!' write ( *, '(a,i6)' ) ' I4_MODP ( I, J ) called with J = ', j stop end if i4_modp = mod ( i, j ) if ( i4_modp < 0 ) then i4_modp = i4_modp + abs ( j ) end if return end subroutine i4_swap ( i, j ) !*****************************************************************************80 ! !! I4_SWAP swaps two integers. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J, the two integers to be swapped. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) k k = i i = j j = k return end function i4_to_a ( i ) !*****************************************************************************80 ! !! I4_TO_A returns the I-th alphabetic character. ! ! Examples: ! ! I I4_TO_A ! ! -8 ' ' ! 0 ' ' ! 1 'A' ! 2 'B' ! .. ! 26 'Z' ! 27 'a' ! 52 'z' ! 53 ' ' ! 99 ' ' ! ! Modified: ! ! 23 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the letter to be returned. ! 0 is a space; ! 1 through 26 requests 'A' through 'Z', (ASCII 65:90); ! 27 through 52 requests 'a' through 'z', (ASCII 97:122); ! ! Output, character I4_TO_A, the requested alphabetic letter. ! implicit none integer ( kind = 4 ), parameter :: cap_shift = 64 integer ( kind = 4 ) i character i4_to_a integer ( kind = 4 ), parameter :: low_shift = 96 if ( i <= 0 ) then i4_to_a = ' ' else if ( 1 <= i .and. i <= 26 ) then i4_to_a = char ( cap_shift + i ) else if ( 27 <= i .and. i <= 52 ) then i4_to_a = char ( low_shift + i - 26 ) else if ( 53 <= i ) then i4_to_a = ' ' end if return end subroutine i4_to_roman ( intval, s ) !*****************************************************************************80 ! !! I4_TO_ROMAN converts an integer to a string of Roman numerals. ! ! Examples: ! ! INTVAL S ! ! -2 -II <-- Not a Roman numeral ! -1 -I <-- Not a Roman numeral ! 0 0 <-- Not a Roman numeral ! 1 I ! 2 II ! 3 III ! 4 IV ! 5 V ! 10 X ! 20 XX ! 30 XXX ! 40 XL ! 50 L ! 60 LX ! 70 LXX ! 80 LXXX ! 90 XC ! 100 C ! 500 D ! 1000 M ! 4999 MMMMCMLXLIX ! ! Discussion: ! ! To generate numbers greater than 4999, the numeral 'V' had a bar ! above it, representing a value of 5000, a barred 'X' represented ! 10,000 and so on. ! ! In the subtractive representation of 4 by 'IV', 9 by 'IX' and so on, ! 'I' can only subtract from 'V' or 'X', ! 'X' can only subtract from 'L' or 'C', ! 'C' can only subtract from 'D' or 'M'. ! Under these rules, 1999 cannot be written IMM! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. If the integer ! has absolute value greater than 4999, the string '?' will be returned. ! If the integer is 0, then the string '0' will be returned. If ! the integer is negative, then a minus sign will precede it, even ! though this has nothing to do with Roman numerals. ! ! Output, character ( len = * ) S, the representation of the integer ! as a Roman numeral. ! implicit none integer ( kind = 4 ) icopy integer ( kind = 4 ) intval character ( len = * ) s s = ' ' icopy = intval if ( 4999 < abs ( icopy ) ) then s = '?' return end if if ( icopy == 0 ) then s = '0' return end if if ( icopy <= 0 ) then s = '-' icopy = - icopy end if do while ( 0 < icopy ) if ( 1000 <= icopy ) then call s_cat ( s, 'M', s ) icopy = icopy - 1000 else if ( 900 <= icopy ) then call s_cat ( s, 'CM', s ) icopy = icopy - 900 else if ( 500 <= icopy ) then call s_cat ( s, 'D', s ) icopy = icopy - 500 else if ( 400 <= icopy ) then call s_cat ( s, 'CD', s ) icopy = icopy - 400 else if ( 100 <= icopy ) then call s_cat ( s, 'C', s ) icopy = icopy - 100 else if ( 90 <= icopy ) then call s_cat ( s, 'XC', s ) icopy = icopy - 90 else if ( 50 <= icopy ) then call s_cat ( s, 'L', s ) icopy = icopy - 50 else if ( 40 <= icopy ) then call s_cat ( s, 'XL', s ) icopy = icopy - 40 else if ( 10 <= icopy ) then call s_cat ( s, 'X', s ) icopy = icopy - 10 else if ( 9 <= icopy ) then call s_cat ( s, 'IX', s ) icopy = icopy - 9 else if ( 5 <= icopy ) then call s_cat ( s, 'V', s ) icopy = icopy - 5 else if ( 4 <= icopy ) then call s_cat ( s, 'IV', s ) icopy = icopy - 4 else call s_cat ( s, 'I', s ) icopy = icopy - 1 end if end do return end subroutine i4_to_s_left ( intval, s ) !*****************************************************************************80 ! !! I4_TO_S_LEFT converts an integer to a left-justified string. ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 1 ! -1 -1 ! 0 0 ! 1952 1952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 03 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be left-justified. If there is not enough space, ! the string will be filled with stars. ! implicit none character c integer ( kind = 4 ) i integer ( kind = 4 ) idig integer ( kind = 4 ) ihi integer ( kind = 4 ) ilo integer ( kind = 4 ) intval integer ( kind = 4 ) ipos integer ( kind = 4 ) ival character ( len = * ) s if ( intval == 0 ) then s = '0' return end if s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! The absolute value of the integer goes into S(ILO:IHI). ! ipos = ihi ! ! Strip off the last digit of IVAL and stick it into the string. ! do while ( ival /= 0 ) idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 end do ! ! Shift the string to the left. ! s(ilo:ilo+ihi-ipos-1) = s(ipos+1:ihi) s(ilo+ihi-ipos:ihi) = ' ' return end subroutine i4_to_s_zero ( intval, s ) !*****************************************************************************80 ! !! I4_TO_S_ZERO converts an integer to a string, with zero padding. ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 000001 ! -1 -00001 ! 0 000000 ! 1952 001952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be right justified, and zero padded. ! If there is not enough space, the string will be filled with stars. ! implicit none character c integer ( kind = 4 ) i integer ( kind = 4 ) idig integer ( kind = 4 ) ihi integer ( kind = 4 ) ilo integer ( kind = 4 ) intval integer ( kind = 4 ) ipos integer ( kind = 4 ) ival character ( len = * ) s s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! Working from right to left, strip off the digits of the integer ! and place them into S(ILO:IHI). ! ipos = ihi do while ( ival /= 0 .or. ipos == ihi ) idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 end do ! ! Fill the empties with zeroes. ! do i = ilo, ipos s(i:i) = '0' end do return end function i4_wrap ( ival, ilo, ihi ) !*****************************************************************************80 ! !! I4_WRAP forces an integer to lie between given limits by wrapping. ! ! Example: ! ! ILO = 4, IHI = 8 ! ! I I4_WRAP ! ! -2 8 ! -1 4 ! 0 5 ! 1 6 ! 2 7 ! 3 8 ! 4 4 ! 5 5 ! 6 6 ! 7 7 ! 8 8 ! 9 4 ! 10 5 ! 11 6 ! 12 7 ! 13 8 ! 14 4 ! ! Modified: ! ! 19 August 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, an integer value. ! ! Input, integer ILO, IHI, the desired bounds for the integer value. ! ! Output, integer I4_WRAP, a "wrapped" version of IVAL. ! implicit none integer ( kind = 4 ) i4_modp integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) ihi integer ( kind = 4 ) ilo integer ( kind = 4 ) ival integer ( kind = 4 ) jhi integer ( kind = 4 ) jlo integer ( kind = 4 ) wide jlo = min ( ilo, ihi ) jhi = max ( ilo, ihi ) wide = jhi - jlo + 1 if ( wide == 1 ) then i4_wrap = jlo else i4_wrap = jlo + i4_modp ( ival - jlo, wide ) end if return end subroutine inflate_common ( y, m, d ) !*****************************************************************************80 ! !! INFLATE_COMMON "inflates" dates in the Common Calendar transition month. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) m integer ( kind = 4 ) y if ( y == 1582 ) then if ( m == 10 ) then if ( 5 <= d ) then d = d + 10 end if end if end if return end subroutine inflate_english ( y, m, d ) !*****************************************************************************80 ! !! INFLATE_ENGLISH "inflates" dates in the English Calendar transition month. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) M, ! integer ( kind = 4 ) D, the YMD date. ! implicit none integer ( kind = 4 ) d integer ( kind = 4 ) m integer ( kind = 4 ) y if ( y == 1752 ) then if ( m == 9 ) then if ( d == 3 ) then d = d + 11 end if end if end if return end subroutine j_borrow_common ( y, j ) !*****************************************************************************80 ! !! J_BORROW_COMMON borrows year-days from years in a Common date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_common do while ( j <= 0 ) y = y - 1 days = year_length_common ( y ) j = j + days end do return end subroutine j_borrow_english ( y, j ) !*****************************************************************************80 ! !! J_BORROW_ENGLISH borrows year-days from years in an English date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_english do while ( j <= 0 ) y = y - 1 days = year_length_english ( y ) j = j + days end do return end subroutine j_borrow_gregorian ( y, j ) !*****************************************************************************80 ! !! J_BORROW_GREGORIAN borrows year-days from years in a Gregorian date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_gregorian do while ( j <= 0 ) y = y - 1 days = year_length_gregorian ( y ) j = j + days end do return end subroutine j_borrow_hebrew ( y, j ) !*****************************************************************************80 ! !! J_BORROW_HEBREW borrows year-days from years in a Hebrew date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_hebrew do while ( j <= 0 ) y = y - 1 days = year_length_hebrew ( y ) j = j + days end do return end subroutine j_borrow_islamic ( y, j ) !*****************************************************************************80 ! !! J_BORROW_ISLAMIC borrows year-days from years in an Islamic date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_islamic do while ( j <= 0 ) y = y - 1 days = year_length_islamic ( y ) j = j + days end do return end subroutine j_borrow_julian ( y, j ) !*****************************************************************************80 ! !! J_BORROW_JULIAN borrows year-days from years in a Julian date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_julian do while ( j <= 0 ) y = y - 1 days = year_length_julian ( y ) j = j + days end do return end subroutine j_borrow_republican ( y, j ) !*****************************************************************************80 ! !! J_BORROW_REPUBLICAN borrows year-days from years in a Republican date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer ( kind = 4 ) J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_republican do while ( j <= 0 ) y = y - 1 days = year_length_republican ( y ) j = j + days end do return end subroutine j_borrow_roman ( y, j ) !*****************************************************************************80 ! !! J_BORROW_ROMAN borrows year-days from years in a Roman date. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_roman do while ( j <= 0 ) y = y - 1 days = year_length_roman ( y ) j = j + days end do return end subroutine j_carry_common ( y, j ) !*****************************************************************************80 ! !! J_CARRY_COMMON carries year-days to years in a Common date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_common do days = year_length_common ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_english ( y, j ) !*****************************************************************************80 ! !! J_CARRY_ENGLISH carries year-days to years in an English date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_english do days = year_length_english ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_gregorian ( y, j ) !*****************************************************************************80 ! !! J_CARRY_GREGORIAN carries year-days to years in a Gregorian date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_gregorian do days = year_length_gregorian ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_hebrew ( y, j ) !*****************************************************************************80 ! !! J_CARRY_HEBREW carries year-days to years in a Hebrew date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_hebrew do days = year_length_hebrew ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_islamic ( y, j ) !*****************************************************************************80 ! !! J_CARRY_ISLAMIC carries year-days to years in an Islamic date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_islamic do days = year_length_islamic ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_julian ( y, j ) !*****************************************************************************80 ! !! J_CARRY_JULIAN carries year-days to years in a Julian date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_julian do days = year_length_julian ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_republican ( y, j ) !*****************************************************************************80 ! !! J_CARRY_REPUBLICAN carries year-days to years in a Republican date. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_republican do days = year_length_republican ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine j_carry_roman ( y, j ) !*****************************************************************************80 ! !! J_CARRY_ROMAN carries year-days to years in a Roman date. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) Y, integer J, a YJ date. ! implicit none integer ( kind = 4 ) days integer ( kind = 4 ) j integer ( kind = 4 ) y integer ( kind = 4 ) year_length_roman do days = year_length_roman ( y ) if ( j < days ) then exit end if j = j - days y = y + 1 end do return end subroutine jed_check ( jed, ierror ) !*****************************************************************************80 ! !! JED_CHECK checks a Julian Ephemeris Date. ! ! Discussion: ! ! The routine returns an error if JED < 0, although there is no ! reason why such dates are invalid. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer ( kind = 4 ) IERROR, is 0 if JED is legal, and 1 otherwise. ! implicit none integer ( kind = 4 ) ierror real ( kind = 8 ) jed if ( 0.0D+00 <= jed ) then ierror = 0 else ierror = 1 end if return end subroutine jed_test ( i, jed ) !*****************************************************************************80 ! !! JED_TEST returns some "interesting" JED's. ! ! Modified: ! ! 09 March 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Bonnie Blackburn, Leofranc Holford-Stevens, ! The Oxford Companion to the Year, ! Oxford, 1999. ! ! Frank Parise, editor, ! The Book of Calendars, ! Facts on File, Inc, 1982, ! CE11.K4 / 529.3. ! ! Edward Reingold, Nachum Dershowitz, ! Calendrical Calculations, the Millennium Edition, ! Cambridge, 2002, ! CE12.R45 / 529.3-dc21 ! ! Edward Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Parameters: ! ! Input, integer ( kind = 4 ) I, the test date requested. ! ! Output, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! If I is less than 1, or greater than the number of test dates ! available, JED is returned as -1.0. ! implicit none integer ( kind = 4 ) i real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch_50000 ! ! JED Epoch: ! Beginning of current Scaliger cycle. ! Monday, Noon, 1 January 4713 BCE/Julian ! if ( i == 1 ) then call epoch_to_jed_jed ( jed ) ! ! The day after the JED Epoch. ! Tuesday, Noon, 2 January 4713 BCE/Julian ! else if ( i == 2 ) then call epoch_to_jed_jed ( jed ) jed = jed + 1.0D+00 ! ! Archbishop James Ussher's estimate of the date of Creation, ! (Noon), 23 October 4004 BCE/Julian ! else if ( i == 3 ) then jed = 259258.000D+00 ! ! Hebrew Epoch. ! 7 October 3761 BCE/Julian ! else if ( i == 4 ) then call epoch_to_jed_hebrew ( jed ) ! ! Mayan Long Count Epoch. ! 6 September 3114 BCE/Julian ! (Reingold and Dershowitz) ! else if ( i == 5 ) then call epoch_to_jed_mayan_long ( jed ) ! ! Hindu Solar Epoch. ! Beginning of the Kali Yuga age. ! 18 February 3102 BCE/Julian ! else if ( i == 6 ) then call epoch_to_jed_hindu_solar ( jed ) ! ! Chinese Epoch. ! 8 March 2637 BCE/Julian ! else if ( i == 7 ) then call epoch_to_jed_chinese ( jed ) ! ! Greek Olympiad Epoch ! 9 July 776 BCE/Julian ! else if ( i == 8 ) then call epoch_to_jed_greek ( jed ) ! ! Roman Epoch ! Ab Urbe Condita ! 1 January 753 BCE/Julian ! else if ( i == 9 ) then call epoch_to_jed_roman ( jed ) ! ! Egyptian Civil Calendar Epoch. ! Ascension of Nabonassar to throne of Babylon. ! 26 February 747 BCE/Julian ! else if ( i == 10 ) then call epoch_to_jed_eg_civil ( jed ) ! ! Egyptian Lunar Calendar Epoch. ! (Don't really know where to set this...) ! Ascension of Nabonassar to throne of Babylon. ! 26 February 747 BCE/Julian ! else if ( i == 11 ) then call epoch_to_jed_eg_lunar ( jed ) ! ! Macedonian Epoch ! 1 September 312 BCE/Julian ! else if ( i == 12 ) then call epoch_to_jed_macedonian ( jed ) ! ! Syrian Epoch ! 1 October 312 BCE/Julian ! else if ( i == 13 ) then call epoch_to_jed_syrian ( jed ) ! ! Alexandrian Epoch ! 29 August 23 BCE/Julian ! else if ( i == 14 ) then call epoch_to_jed_alexandrian ( jed ) ! ! Julian Epoch MINUS ONE DAY ! Friday, 31 December 1 BCE/Julian ! else if ( i == 15 ) then call epoch_to_jed_julian ( jed ) jed = jed - 1.0D+00 ! ! Julian Epoch ! Saturday, 1 January 1 CE/Julian ! else if ( i == 16 ) then call epoch_to_jed_julian ( jed ) ! ! Gregorian Epoch ! Monday, 3 January 1 CE/Julian ! Monday, 1 January 1 Gregorian ! else if ( i == 17 ) then call epoch_to_jed_gregorian ( jed ) ! ! RD: Reingold and Dershowitz Epoch ! Monday, 3 January 1 CE/Julian ! Monday, 1 January 1 Gregorian ! else if ( i == 18 ) then call epoch_to_jed_rd ( jed ) ! ! Ethiopian Epoch ! 29 August 8 CE/Julian ! (Reingold and Dershowitz) ! else if ( i == 19 ) then call epoch_to_jed_ethiopian ( jed ) ! ! Hindu Lunar Epoch, the Vikrama ! 24 March 57 CE/Julian ! (The actual day and month are not specified by RD) ! (Reingold and Dershowitz) ! else if ( i == 20) then call epoch_to_jed_hindu_lunar ( jed ) ! ! Saka Epoch ! 4 March 79 CE/Julian ! else if ( i == 21 ) then call epoch_to_jed_saka ( jed ) ! ! Coptic Epoch ! 29 August 284 CE/Julian ! else if ( i == 22 ) then call epoch_to_jed_coptic ( jed ) ! ! Zoroastrian Epoch. ! 3 March 388 CE/Julian ! else if ( i == 23 ) then call epoch_to_jed_zoroastrian ( jed ) ! ! Armenian Epoch ! 11 July 552 CE/Julian ! else if ( i == 24 ) then call epoch_to_jed_armenian ( jed ) ! ! Fasli Deccan Epoch ! 12 July 590 CE/Julian ! else if ( i == 25 ) then call epoch_to_jed_deccan ( jed ) ! ! Fasli Soor San Epoch ! 24 May 600 CE/Julian ! else if ( i == 26 ) then call epoch_to_jed_soor_san ( jed ) ! ! Persian Solar Epoch ! 19 March 622 CE/Julian ! else if ( i == 27 ) then call epoch_to_jed_persian_solar ( jed ) ! ! Islamic A Epoch ! Thursday, 15 July 622 CE/Julian ! else if ( i == 28 ) then call epoch_to_jed_islamic_a ( jed ) ! ! Islamic B Epoch ! Friday, 16 July 622 CE/Julian ! else if ( i == 29 ) then call epoch_to_jed_islamic_b ( jed ) ! ! Yazdegerd Epoch ! 16 June 632 CE ! else if ( i == 30 ) then call epoch_to_jed_persian ( jed ) ! ! Khwarizmian Epoch ! 21 June 632 CE/Julian ! else if ( i == 31 ) then call epoch_to_jed_khwarizmian ( jed ) ! ! Jelali Epoch ! 17 March 1078 CE/Julian ! else if ( i == 32 ) then call epoch_to_jed_jelali ( jed ) ! ! Akbar Epoch ! 9 February 1556 CE/Julian ! 19 February 1556 Gregorian ! else if ( i == 33 ) then call epoch_to_jed_akbar ( jed ) ! ! Common Era calendar transition: ! Noon of the last day of Julian calendar usage. ! Thursday, 04 October 1582 CE/English/Julian ! Thursday, 14 October 1582 Gregorian ! else if ( i == 34 ) then call transition_to_jed_common ( jed ) jed = jed - 0.5D+00 ! ! Common Era calendar transition: ! Noon of the first day of Gregorian calendar usage. ! Friday, 05 October 1582 English/Julian ! Friday, 15 October 1582 CE/Gregorian ! else if ( i == 35 ) then call transition_to_jed_common ( jed ) jed = jed + 0.5D+00 ! ! A day chosen by Lewis Carroll to test his day-of-the-week algorithm, ! Wednesday, 4 March 1676 CE/Gregorian ! Wednesday, 23 February 1676 English/Julian ! else if ( i == 36 ) then jed = 2333269.5D+00 ! ! English calendar ! noon of the last day of Julian calendar usage. ! 02 September 1752 English/Julian ! 13 September 1752 CE/Gregorian ! else if ( i == 37 ) then call transition_to_jed_english ( jed ) jed = jed - 0.5D+00 ! ! English calendar, ! noon of the first day of Gregorian calendar usage. ! 03 September 1752 Julian ! 14 September 1752 CE/English/Gregorian ! else if ( i == 38 ) then call transition_to_jed_english ( jed ) jed = jed + 0.5D+00 ! ! A day chosen by Lewis Carroll to test his day-of-the-week algorithm, ! Thursday, 18 September 1783 CE/Gregorian ! else if ( i == 39 ) then jed = 2372547.5D+00 ! ! French Republican Epoch ! Saturday, 11 September 1792 Julian ! Saturday, 22 September 1792 CE/Gregorian ! else if ( i == 40) then call epoch_to_jed_republican ( jed ) ! ! Bahai Epoch. ! 9 March 1844 Julian ! 21 March 1844 CE/Gregorian ! else if ( i == 41 ) then call epoch_to_jed_bahai ( jed ) ! ! Clive James Lucas test date. ! else if ( i == 42 ) then jed = 2394710.50D+00 ! ! New York Times "epoch" date, ! fictitious Volume 1, issue #0, ! 17 September 1851 ! (issue #1 was on 18 September 1851): ! else if ( i == 43 ) then jed = 2397383.50D+00 ! ! Modified Julian Date Epoch. ! 17 November 1858 CE/Gregorian ! else if ( i == 44 ) then call epoch_to_jed_mjd ( jed ) ! ! NYT issue 10,000 ! 24 September 1883 ! else if ( i == 45 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 - 40000.0D+00 - 88.0D+00 ! ! Bessel Year Count Epoch. ! 1 January 1900 CE/Gregorian ! else if ( i == 46 ) then call epoch_to_jed_bessel ( jed ) ! ! NYT issue 30,000 ! 14 March 1940 ! else if ( i == 47 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 - 20000.0D+00 - 88.0D+00 ! ! NYT issue 40,000 ! ??? ! else if ( i == 48 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 - 10000.0D+00 - 88.0D+00 ! ! UNIX epoch. ! 1 January 1970 CE/Gregorian. ! else if ( i == 49 ) then call epoch_to_jed_unix ( jed ) ! ! NYT issue 44027 ! ??? ! else if ( i == 50 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 - 5973 ! ! NYT issue 44028 ! ??? ! else if ( i == 51 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 - 5972 ! ! GPS epoch. ! 6 January 1980 CE/Gregorian ! else if ( i == 52 ) then call epoch_to_jed_gps ( jed ) ! ! NYT issue 50,000 ! 14 March 1995 ! else if ( i == 53 ) then jed_epoch_50000 = 2449790.5D+00 jed = jed_epoch_50000 ! ! 25 February 1996 ! A Reingold/Dershowitz test date. ! else if ( i == 54 ) then jed = 2450138.5D+00 ! ! Y2K day ! 1 January 2000 CE/Gregorian ! else if ( i == 55 ) then call epoch_to_jed_y2k ( jed ) ! ! Today ! else if ( i == 56 ) then call now_to_jed ( jed ) ! ! End of Current Mayan Great Cycle ! 23 December 2012 CE/Gregorian ! else if ( i == 57 ) then call transition_to_jed_mayan_long ( jed ) ! ! Scaliger cycle repeats. ! 1 January 3266 CE/Gregorian ! else if ( i == 58 ) then call transition_to_jed_jed ( jed ) else jed = -1.0D+00 end if return end subroutine jed_to_cws_gps ( jed, c, w, s ) !*****************************************************************************80 ! !! JED_TO_CWS_GPS converts a JED to a GPS CWS date. ! ! Discussion: ! ! The GPS time keeping is in terms of seconds, weeks, and cycles ! of 1024 weeks. The weeks and cycles begin numbering at 0. ! ! The computation is only valid for dates after the GPS epoch, ! that is, after 6 January 1980. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer C, integer W, real ( kind = 8 ) S, the corresponding GPS ! cycles/weeks/seconds date. ! implicit none integer ( kind = 4 ) c real ( kind = 8 ) d real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch integer ( kind = 4 ) w real ( kind = 8 ) s call epoch_to_jed_gps ( jed_epoch ) d = jed - jed_epoch if ( d < 0.0D+00 ) then s = -1.0 w = -1 c = -1 return end if w = int ( d ) / 7 d = d - real ( 7 * w, kind = 8 ) c = w / 1024 w = w - 1024 * c s = d * real ( 24.0D+00 * 60.0D+00 * 60.0D+00, kind = 8 ) return end subroutine jed_to_mayan_long ( jed, pictun, baktun, katun, tun, uinal, kin, f ) !*****************************************************************************80 ! !! JED_TO_MAYAN_LONG converts a JED to a Mayan long count date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, chapter 27. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer PICTUN, BAKTUN, KATUN, TUN, UINAL, KIN, values ! defining the Mayan long date. ! ! Output, real ( kind = 8 ) F, the fractional part of the date. ! implicit none integer ( kind = 4 ) baktun integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) j real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch integer ( kind = 4 ) katun integer ( kind = 4 ) kin integer ( kind = 4 ) pictun integer ( kind = 4 ) tun integer ( kind = 4 ) uinal call epoch_to_jed_mayan_long ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - real ( j, kind = 8 ) days = j if ( 0 <= days ) then pictun = days / 2880000 days = days - pictun * 2880000 else pictun = 0 do while ( days < 0 ) pictun = pictun - 1 days = days + 2880000 end do end if baktun = days / 144000 days = days - baktun * 144000 katun = days / 7200 days = days - katun * 7200 tun = days / 360 days = days - tun * 360 uinal = days / 20 days = days - uinal * 20 kin = days return end subroutine jed_to_mayan_round ( jed, y, a, b, c, d, f ) !*****************************************************************************80 ! !! JED_TO_MAYAN_ROUND converts a JED to a Mayan round date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm K, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 340. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, A, B, C, D, values defining the Mayan round date. ! ! Output, real ( kind = 8 ) F, the fractional part of the date. ! implicit none integer ( kind = 4 ) a integer ( kind = 4 ) b integer ( kind = 4 ) c integer ( kind = 4 ) d integer ( kind = 4 ) days real ( kind = 8 ) f integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) j real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch integer ( kind = 4 ) n integer ( kind = 4 ) y call epoch_to_jed_mayan_long ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - real ( j, kind = 8 ) days = j y = 0 do while ( days < 0 ) days = days + 18980 y = y - 1 end do y = y + days / 18980 days = mod ( days, 18980 ) a = i4_wrap ( days + 4, 1, 13 ) b = i4_wrap ( days, 1, 20 ) n = mod ( days + 348, 365 ) c = mod ( n, 20 ) d = n / 20 return end subroutine jed_to_mjd ( jed, mjd ) !*****************************************************************************80 ! !! JED_TO_MJD converts a JED to a modified JED. ! ! Modified: ! ! 11 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) MJD, the modified Julian Ephemeris Date. ! implicit none real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ) mjd call epoch_to_jed_mjd ( jed_epoch ) mjd = jed - jed_epoch return end subroutine jed_to_nearest_noon ( jed1, jed2 ) !*****************************************************************************80 ! !! JED_TO_NEAREST_NOON converts a JED to the JED of the nearest noon. ! ! Discussion: ! ! This is primarily to make a fair test of the weekday routines, ! which have trouble when the JED is at midnight. ! ! Note that noon corresponds to an integral JED value. ! ! Modified: ! ! 07 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED1, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) JED2, the Julian Ephemeris Date ! of the nearest noon. If JED1 was at midnight, JED2 is ! advanced to the NEXT noon, not the previous one. ! implicit none real ( kind = 8 ) jed1 real ( kind = 8 ) jed2 jed2 = anint ( jed1 ) return end subroutine jed_to_next_noon ( jed1, jed2 ) !*****************************************************************************80 ! !! JED_TO_NEXT_NOON converts a JED to the JED of the next noon. ! ! Discussion: ! ! This is primarily to make a fair test of the weekday routines, ! which have trouble when the JED is at midnight. ! ! Note that noon corresponds to an integral JED value. ! ! Modified: ! ! 08 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED1, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) JED2, the Julian Ephemeris Date ! of the next noon. ! implicit none real ( kind = 8 ) jed1 real ( kind = 8 ) jed2 jed2 = aint ( jed1 ) ! ! The integer part of JED1 is one of the two integers that ! bracket JED1. If it's the smaller one (which it should ! be as long as JED1 is positive), make it the bigger one. ! ! This correctly leaves undisturbed cases where JED1 is ! already an integer, and where JED1 is negative (which ! is not a case we expect to occur often). ! if ( jed2 < jed1 ) then jed2 = jed2 + 1.0D+00 end if return end subroutine jed_to_nyt ( jed, volume, issue ) !*****************************************************************************80 ! !! JED_TO_NYT converts a JED to an NYT date. ! ! Discussion: ! ! The New York Times began publication with Volume 1, Issue 1 on ! Thursday, 18 September 1851. ! ! The issue was not reset to 1 at the beginning of the next year, but ! steadily increased. ! ! It seemed an initriguing idea, then, to devise a formula that would ! produce the New York Times issue number for a given date, or that ! could start with the issue number and return the date on which that ! issue appeared. ! ! In a simple world, this would have been essentially a translation ! of the JED, that is, the first approximation would be ! ! NYT(today) - NYT(18 September 1851) = JED(today) - JED(18 September 1851) ! ! so ! ! NYT(today) = NYT(18 September 1851) + JED(today) - JED(18 September 1851) ! ! and we're done. ! ! However, the first problem involved Sunday issues. No Sunday paper was ! printed at all, until 21 April 1861. Moreover, that paper was given ! the issue number 2990, which was the same issue number as the Saturday ! paper. This persisted until some time around April 1905, when Sunday ! papers were assigned their own issue number. Once this was done, the ! New York Times issue number began to "track" the Julian Ephemeris Date ! in a simple way. ! ! The second obvious problem occurred because there was an 88 day strike ! in 1978. The issue for August 9 was 44027, and the issue for November 6 ! was 44028 (I THINK, I AM NOT COMPLETELY SURE HERE). During other strikes, ! the New York Times had increased the issue number each day, even if no paper ! was printed. This was the first time that a strike caused the issue number ! sequence to halt. ! ! The third problem was more subtle. An article printed on 14 March 1995 ! heralded the printing of issue 50,000 of the New York Times. It also ! mentioned issues and corresponding dates for several points in the past, ! explained the 88 day strike lacuna, and the fact that there were no ! Sunday papers at all until 21 April 1861. This information seemed enough ! to define a new formula that would work for the present era, at least, ! after Sunday papers were printed and given their own issue number. ! We could do this by basing the formula on the JED for issue 50,000, which ! turned out to have the value 2449790.5. ! ! For days on or after 6 November 1978, ! ! NYT(today) = NYT(14 March 1995) + JED(today) - JED(14 March 1995) ! ! For days on or before 9 August 1978, ! ! NYT(today) = NYT(14 March 1995) + JED(today) - JED(14 March 1995) + 88 ! ! I set up this formula, and it worked pretty well for my list of known ! dates and issue numbers between 1909 and 1995. ! ! Then I pulled out the New York Times that I had bought that day ! (22 November 2007), and tried out the formula. To my dismay, the value ! returned by the formula was exactly 500 higher than the value printed ! on my paper. This was very disturbing! ! ! Going online, I tried to find more examples of issues and dates in the ! interval between 14 March 1995 and 22 November 2007. This was harder ! than you might think. Almost no one refers to the issue number. Even ! the article indexes for the New York Times, whether printed or online, ! refer only to the date. I ended up having to scan for images of the ! front page. There were surprisingly many, but most were of such poor ! quality that the issue number could not be read. Patience rewarded ! me, though, with data for 1997, then for 2005, then for 2003, then ! 2002. Gradually, I began to jokingly assume that the dreaded Year 2000 ! catastrophe had somehow hit the New York Times! ! ! Imagine my shock when a colleague whom I had dragged into the search ! with me discovered that this was true in a way. On the front page of ! the New York Times for 1 January 2000 was the statement that a mistake ! in issue numbering, made in 1898 and never noticed until recently, ! was being corrected. The issue numbers had been accidentally "inflated" ! by 500 back then, so they were now being "corrected" by dropping 500. ! ! The ghastly details were: ! ! Date Issue ! ---------------- ------ ! 06 February 1898 14,499 ! 07 February 1898 15,000 ! 31 December 2000 51,753 ! 01 January 2001 51,254 ! ! With this information, it becomes possible to adjust the formula to ! be correct for current issues, and back over the "hiccup" in 1898. ! The formula, however, obviously becomes more complicated, and, what's ! worse, the issue number itself no longer can be used to deduce the ! date, since there is now a sequence of 500 issue numbers that were used ! twice. Luckily, if we require the Volume number as well, we have ! enough information to go back and forth. ! ! The formula for the New York Times Volume Number is not as simple ! as it could be. The Volume started at 1 on 18 September 1851, and ! increases by 1 each successive 18 September. To determine the ! volume number for a given date, you need to go "backwards" to the ! most recent elapsed 18 September, note the year in which that occurred, ! subtract 1851 from that, and add 1! ! ! NYT_VOLUME = Year(Most-recently-elapsed-18-September) - 1851 + 1. ! ! Now I have to work out the details of the formula to allow for the ! two hiccups and the strike, and I should have a start on a usable pair ! of formulas. ! ! This excruciating (and unfinished) effort demonstrates, I hope, that ! calendars are human creations, which aspire to mathematical regularity, ! but which inevitably acquire the irregularities and ambiguities of all ! human creations! ! ! Modified: ! ! 02 December 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Anonymous, ! A Correction; Welcome to 51,254, ! The New York Times, ! 01 January 2000, Volume 149, Issue 51254. ! ! James Barron, ! What's in a Number? 143 Years of News, ! The New York Times, ! 14 March 1995, Volume 144, Issue 50000. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer ( kind = 4 ) VOLUME, ISSUE, the New York Times ! volume and issue. ! implicit none integer ( kind = 4 ) d real ( kind = 8 ) f integer ( kind = 4 ) issue real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ), parameter :: jed_epoch_50000 = 2449790.5D+00 integer ( kind = 4 ) m integer ( kind = 4 ) volume integer ( kind = 4 ) y ! call epoch_to_jed_nyt ( jed_epoch ) ! issue = int ( jed - jed_epoch ) issue = 50000 + int ( jed - jed_epoch_50000 ) if ( issue < 44028 ) then if ( 44028 <= issue + 88 ) then issue = 44027 else issue = issue + 88 end if end if if ( 51753 < issue ) then issue = issue - 500 end if ! ! A first stab at the volume computation. ! call jed_to_ymdf_common ( jed, y, m, d, f ) volume = y - 1851 + 1 if ( ( m == 9 .and. d < 18 ) .or. m < 9 ) then volume = volume - 1 end if return end subroutine jed_to_rd ( jed, rd ) !*****************************************************************************80 ! !! JED_TO_RD converts a JED to an RD. ! ! Modified: ! ! 05 November 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Reingold, Nachum Dershowitz, ! Calendrical Calculations, the Millennium Edition, ! Cambridge, 2002. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) RD, the RD date. ! implicit none real ( kind = 8 ) jed real ( kind = 8 ) rd real ( kind = 8 ) rd_epoch call epoch_to_jed_rd ( rd_epoch ) rd = jed - rd_epoch return end subroutine jed_to_ss_unix ( jed, s ) !*****************************************************************************80 ! !! JED_TO_SS_UNIX converts a JED to a UNIX SS date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) S, the corresponding UNIX SS date. ! implicit none real ( kind = 8 ) d real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ) s call epoch_to_jed_unix ( jed_epoch ) d = jed - jed_epoch s = d * 24.0D+00 * 60.0D+00 * 60.0D+00 return end subroutine jed_to_weekday ( jed, w, f ) !*****************************************************************************80 ! !! JED_TO_WEEKDAY computes the day of the week from a JED. ! ! Discussion: ! ! BC 4713/01/01 => JED = 0.0 was noon on a Monday. ! ! jedmod = mod ( 0.0D+00, 7.0D+00 ) = 0.0D+00 ! j = mod ( nint ( 0 ), 7 ) = 0 ! f = ( 0.0D+00 + 0.5D+00 ) - real ( j ) = 0.5D+00 ! w = i4_wrap ( 0 + 2, 1, 7 ) = 2 = MONDAY ! ! Modified: ! ! 07 November 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! ! Output, real ( kind = 8 ) F, the fractional part of the day. ! implicit none real ( kind = 8 ) f integer ( kind = 4 ) i4_wrap integer ( kind = 4 ) j real ( kind = 8 ) jed real ( kind = 8 ) jedmod integer ( kind = 4 ) w jedmod = mod ( jed, 7.0D+00 ) j = mod ( nint ( jedmod ), 7 ) f = ( jedmod + 0.5D+00 ) - real ( j, kind = 8 ) w = i4_wrap ( j + 2, 1, 7 ) return end subroutine jed_to_year_hebrew ( jed, y ) !*****************************************************************************80 ! !! JED_TO_YEAR_HEBREW determines the year in the Hebrew calendar when a JED occurred. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Edward Richards, ! Algorithm H, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 331. ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, the year in the Hebrew calendar that included the JED. ! If the input JED is less than the epoch of the Hebrew calendar, ! then Y is always returned as -1. ! implicit none integer ( kind = 4 ) i4_modp real ( kind = 8 ) jed real ( kind = 8 ) jed2 real ( kind = 8 ) jed_epoch integer ( kind = 4 ) m integer ( kind = 4 ) y call epoch_to_jed_hebrew ( jed_epoch ) if ( jed < jed_epoch ) then y = -1 return end if ! ! Using integer arithmetic in this computation may cause overflow. ! ! Compute the number of months elapsed up to the date. ! m = 1 + int ( ( 25920.0D+00 * ( jed - jed_epoch + 2.5D+00 ) ) / 765433.0D+00 ) ! ! Estimate the number of years represented by these months. ! y = 19 * ( m / 235 ) + ( 19 * ( i4_modp ( m, 235 ) - 2 ) ) / 235 + 1 ! ! Determine the JED of the first day of that year. ! call new_year_to_jed_hebrew ( y, jed2 ) ! ! We might have been off by 1 year. ! if ( jed < jed2 ) then y = y - 1 end if return end subroutine jed_to_yearcount_bessel ( jed, bessel ) !*****************************************************************************80 ! !! JED_TO_YEARCOUNT_BESSEL converts a JED to Bessel year count. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) BESSEL, the Bessel year. ! implicit none real ( kind = 8 ) bessel real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ), parameter :: year_length = 365.242198781D+00 call epoch_to_jed_bessel ( jed_epoch ) bessel = 1900.0D+00 + ( jed - jed_epoch ) / year_length return end subroutine jed_to_yearcount_julian ( jed, julian ) !*****************************************************************************80 ! !! JED_TO_YEARCOUNT_JULIAN converts a JED to a Julian year count. ! ! Discussion: ! ! An average year in the Julian calendar is exactly 365.25 days long. ! This calculation counts the number of average Julian years from ! the beginning of the year 2000. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, real ( kind = 8 ) JULIAN, the Julian year. ! implicit none real ( kind = 8 ) jed real ( kind = 8 ) jed_epoch real ( kind = 8 ) julian real ( kind = 8 ), parameter :: year_length = 365.25D+00 call epoch_to_jed_y2k ( jed_epoch ) julian = 2000.0D+00 + ( jed - jed_epoch ) / year_length return end subroutine jed_to_yjf_common ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_COMMON converts a JED to a Common YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_common ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_common ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_english ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_ENGLISH converts a JED to an English YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_english ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_english ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_gregorian ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_GREGORIAN converts a JED to a Gregorian YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_gregorian ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_gregorian ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_hebrew ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_HEBREW converts a JED to a Hebrew YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_hebrew ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_hebrew ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_islamic_a ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_ISLAMIC_A converts a JED to an Islamic-A YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_islamic_a ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_islamic ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_islamic_b ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_ISLAMIC_B converts a JED to an Islamic-B YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_islamic_b ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_islamic ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_julian ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_JULIAN converts a JED to a Julian YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_julian ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_julian ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_republican ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_REPUBLICAN converts a JED to a Republican YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 integer ( kind = 4 ) j real ( kind = 8 ) jed integer ( kind = 4 ) m1 integer ( kind = 4 ) y integer ( kind = 4 ) y1 call jed_to_ymdf_republican ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_republican ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_yjf_roman ( jed, y, j, f ) !*****************************************************************************80 ! !! JED_TO_YJF_ROMAN converts a JED to a Roman YJF date. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, real ( kind = 8 ) F, the YJF date. ! implicit none integer ( kind = 4 ) d1 real ( kind = 8 ) f real ( kind = 8 ) f1 in