subroutine ch_cap ( c ) ! !******************************************************************************* ! !! 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 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 ) ! !******************************************************************************* ! !! CWS_TO_JED_GPS converts a GPS CWS date to a JED. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer C, integer W, double precision S, the GPS ! cycle/week/second date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer c double precision d double precision jed double precision jed_epoch double precision s integer w ! call epoch_to_jed_gps ( jed_epoch) d = dble ( 7 * ( 1024 * c + w ) ) + 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 ) ! !******************************************************************************* ! !! 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 C, integer W, double precision SEC, the GPS ! cycle/week/second date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer c character ( len = 25 ) s1 character ( len = 4 ) s2 character ( len = 9 ) s3 character ( len = * ) s double precision sec integer w ! call i_to_s_left ( c, s1 ) call s_cat ( s1, '/', s1 ) call i_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 d_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! D_RANDOM returns a random double precision in a given range. ! ! ! Discussion: ! ! Calls to the FORTRAN 90 random number generator should go through ! this routine, to guarantee that the random number seed has been set. ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision RLO, RHI, the minimum and maximum values. ! ! Output, double precision R, the randomly chosen value. ! implicit none ! double precision r double precision rhi double precision rlo integer, save :: seed = 0 logical, save :: seeded = .false. double precision t ! ! Make sure the random number generator has been seeded. ! if ( .not. seeded ) then call random_initialize ( seed ) seeded = .true. end if ! ! Pick T, a random number in (0,1). ! call random_number ( harvest = t ) ! ! Set R in ( RLO, RHI ). ! r = ( 1.0D+00 - t ) * rlo + t * rhi return end subroutine d_to_s_left ( d, s ) ! !******************************************************************************* ! !! D_TO_S_LEFT writes a double precision value into a left justified string. ! ! ! Method: ! ! A 'G20.12' format is used with a WRITE statement. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision D, the number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 20 ! characters long, it will will be returned as a series of ! asterisks. ! implicit none ! double precision d integer i integer nchar character ( len = * ) s character ( len = 20 ) s2 ! nchar = len ( s ) if ( nchar < 20 ) then do i = 1, nchar s(i:i) = '*' end do else if ( d == 0.0D+00 ) then s(1:20) = ' 0.0 ' else write ( s2, '(g20.12)' ) d s(1:20) = s2 end if ! ! Shift the string left. ! s = adjustl ( s ) return end subroutine day_borrow_alexandrian ( y, m, d ) ! !******************************************************************************* ! !! DAY_BORROW_ALEXANDRIAN borrows days from months in an Alexandrian date. ! ! ! Modified: ! ! 13 November 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 d integer days integer m integer month_length_alexandrian integer 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 ) ! !******************************************************************************* ! !! DAY_BORROW_COMMON borrows days from months in a Common 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 d integer days integer m integer month_length_common integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_eg_civil integer y ! do while ( d <= 0 ) m = m - 1 call month_borrow_eg_civil ( y, m ) days = month_length_eg_civil ( m ) d = d + days end do return end subroutine day_borrow_english ( y, m, d ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_english integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_gregorian integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_hebrew integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_islamic integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_julian integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_republican integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_roman integer 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_alexandrian integer months integer y ! days = month_length_alexandrian ( y, m ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! DAY_CARRY_COMMON carries days to months in a Common date. ! ! ! Algorithm: ! ! While D > number of days in M: ! 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 d integer days integer m integer month_length_common integer 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 ( d > days ) 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 ) ! !******************************************************************************* ! !! DAY_CARRY_EG_CIVIL carries days to months in an Egyptian Civil 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 d integer days integer m integer month_length_eg_civil integer months integer y ! days = month_length_eg_civil ( m ) do while ( d > days ) d = d - days m = m + 1 days = month_length_eg_civil ( 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 ) ! !******************************************************************************* ! !! DAY_CARRY_ENGLISH carries days to months in an English date. ! ! ! Algorithm: ! ! While D > number of days in M: ! 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 d integer days integer m integer month_length_english integer 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 ( d > days ) 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 ) ! !******************************************************************************* ! !! DAY_CARRY_GREGORIAN carries days to months in a Gregorian date. ! ! ! Algorithm: ! ! While D > number of days in M: ! 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 d integer days integer m integer month_length_gregorian integer y ! days = month_length_gregorian ( y, m ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_hebrew integer months integer y integer year_length_months_hebrew ! days = month_length_hebrew ( y, m ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_islamic integer months integer y integer year_length_months_islamic ! days = month_length_islamic ( y, m ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_julian integer y ! days = month_length_julian ( y, m ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_republican integer months integer y integer year_length_months_republican ! days = month_length_republican ( y, m ) months = year_length_months_republican ( y ) do while ( d > days ) 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 ) ! !******************************************************************************* ! !! 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 d integer days integer m integer month_length_roman integer months integer y integer year_length_months_roman ! days = month_length_roman ( y, m ) months = year_length_months_roman ( y ) do while ( d > days ) 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 function days_before_month_common ( y, m ) ! !******************************************************************************* ! !! 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 ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer days_before_month_common integer y integer 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 ( m2 > 2 .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 ) ! !******************************************************************************* ! !! 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 ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer days_before_month_gregorian integer y integer 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 ( m2 > 2 .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 ) ! !******************************************************************************* ! !! 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 ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /) integer days_before_month_julian integer y integer 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 ( m2 > 2 .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 ) ! !******************************************************************************* ! !! 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 d integer m integer y ! if ( y == 1582 ) then if ( m == 10 ) then if ( d >= 15 ) then d = d - 10 end if end if end if return end subroutine deflate_english ( y, m, d ) ! !******************************************************************************* ! !! 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 d integer m integer y ! if ( y == 1752 ) then if ( m == 9 ) then if ( d >= 14 ) then d = d - 11 end if end if end if return end subroutine digit_to_ch ( digit, c ) ! !******************************************************************************* ! !! 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 digit ! if ( 0 <= digit .and. digit <= 9 ) then c = char ( digit + 48 ) else c = '*' end if return end subroutine easter_ds ( y, m, d ) ! !******************************************************************************* ! !! EASTER_DS computes the month and day of Easter for a Common year. ! ! ! Example: ! ! Input: ! ! Y = 2000 ! ! Output: ! ! M = 4 ! D = 23 ! ! Reference: ! ! Peter Duffett-Smith, ! Practical Astronomy With Your Calculator, ! Third Edition, ! Cambridge University Press, 1996. ! ! Modified: ! ! 07 November 1999 ! ! 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 a integer b integer c integer d integer dd integer e integer f integer g integer h integer i integer k integer l integer m integer mm integer 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 ) ! !******************************************************************************* ! !! EASTER_EGR computes the month and day of Easter for a Common year. ! ! ! Reference: ! ! E G Richards, ! Algorithm O, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 375. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none ! integer c integer d integer e integer g integer h integer i_wrap integer m integer n integer p integer q integer r integer s integer u integer vp integer 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 = i_wrap ( r + 3, 1, 7 ) s = r + mod ( 7 + n - c, 7 ) m = 3 + ( s / 32 ) d = i_wrap ( s, 1, 31 ) return end subroutine easter_egr2 ( y, m, d ) ! !******************************************************************************* ! !! EASTER_EGR2 computes the month and day of Easter for a Common year. ! ! ! Reference: ! ! E G Richards, ! Algorithm P, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 376. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none ! integer a integer b integer c integer d integer e integer i_wrap integer m integer s integer 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 = i_wrap ( s, 1, 31 ) return end subroutine easter_julian ( y, m, d ) ! !******************************************************************************* ! !! 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. ! ! Reference: ! ! E G Richards, ! Algorithm M, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 365. ! ! Modified: ! ! 31 March 2000 ! ! 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 c integer d integer e integer g integer i_wrap integer m integer n integer p integer r integer s integer 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 = i_wrap ( r + 3, 1, 7 ) s = r + mod ( 7 + n - c, 7 ) m = 3 + ( s / 32 ) ! ! Use wrapping so that 1 <= D <= 31. ! d = i_wrap ( s, 1, 31 ) return end subroutine easter_julian2 ( y, m, d ) ! !******************************************************************************* ! !! 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. ! ! Reference: ! ! E G Richards, ! Algorithm N, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 365. ! ! Modified: ! ! 31 March 2000 ! ! 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 a integer b integer d integer i_wrap integer m integer s integer 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 = i_wrap ( s, 1, 31 ) return end subroutine easter_knuth ( y, m, d ) ! !******************************************************************************* ! !! 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 ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1: Fundamental Algorithms, ! Addison Wesley, 1968, pages 155-156. ! ! Communications of the ACM, ! Volume 5, 1962, pages 209-210, page 556. ! ! T H O'Beirne, ! Puzzles and Paradoxes, ! Oxford University Press, 1965, chapter 10. ! ! Modified: ! ! 05 April 2000 ! ! 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 c integer d integer dd integer e integer g integer i_modp integer m integer n integer x integer y integer 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 = i_modp ( 11 * g + 20 + z - x, 30 ) if ( ( e == 25 .and. g > 11 ) .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 ( n > 31 ) then d = n - 31 m = 4 else d = n m = 3 end if return end subroutine easter_stewart ( y, m, d ) ! !******************************************************************************* ! !! 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 ! ! Reference: ! ! Thomas O'Beirne, ! Puzzles and Paradoxes, ! Oxford University Press, 1965. ! ! Ian Stewart, ! Easter is a Quasicrystal, ! Scientific American, ! March 2001, pages 80-83. ! ! Modified: ! ! 18 February 2001 ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer M, D, the month and day of Easter. ! implicit none ! integer a integer b integer c integer d integer dd integer e integer g integer h integer j integer k integer l integer m integer mm integer 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 ) ! !******************************************************************************* ! !! EPOCH_TO_JED_AKBAR returns the epoch of the Akbar calendar as a JED. ! ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2289426.5D+00 return end subroutine epoch_to_jed_alexandrian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ALEXANDRIAN returns the epoch of the Alexandrian calendar as a JED. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1713262.5D+00 return end subroutine epoch_to_jed_armenian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ARMENIAN returns the epoch of the Armenian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1922867.5D+00 return end subroutine epoch_to_jed_bahai ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_BAHAI returns the epoch of the Bahai calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2394710.5D+00 return end subroutine epoch_to_jed_bessel ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_BESSEL returns the epoch of the Bessel calendar as a JED. ! ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2415020.31352D+00 return end subroutine epoch_to_jed_chinese ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_CHINESE returns the epoch of the Chinese calendar as a JED. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 758326.5D+00 return end subroutine epoch_to_jed_common ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_COMMON returns the epoch of the Common calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1721423.5D+00 return end subroutine epoch_to_jed_coptic ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_COPTIC returns the epoch of the Coptic calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1825029.5D+00 return end subroutine epoch_to_jed_deccan ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_DECCAN returns the epoch of the Fasli Deccan calendar as a JED. ! ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1936748.5D+00 return end subroutine epoch_to_jed_eg_civil ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_EG_CIVIL returns the epoch of the Egyptian Civil calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1448638.5D+00 return end subroutine epoch_to_jed_eg_lunar ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1448638.5D+00 return end subroutine epoch_to_jed_english ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ENGLISH returns the epoch of the English calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1721423.5D+00 return end subroutine epoch_to_jed_ethiopian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ETHIOPIAN returns the epoch of the Ethiopian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1724220.5D+00 return end subroutine epoch_to_jed_gps ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_GPS returns the epoch of the GPS calendar as a JED. ! ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2444244.5D+00 return end subroutine epoch_to_jed_greek ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1438180.5D+00 return end subroutine epoch_to_jed_gregorian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_GREGORIAN returns the epoch of the Gregorian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1721425.5D+00 return end subroutine epoch_to_jed_hebrew ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_HEBREW returns the epoch of the Hebrew calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 347998.5D+00 return end subroutine epoch_to_jed_hindu_solar ( jed ) ! !******************************************************************************* ! !! 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: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 588466.75D+00 return end subroutine epoch_to_jed_islamic_a ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1948438.5D+00 return end subroutine epoch_to_jed_islamic_b ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1948439.5D+00 return end subroutine epoch_to_jed_jed ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_JED returns the epoch of the JED as a JED. ! ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! double precision jed ! jed = 0.0D+00 return end subroutine epoch_to_jed_jelali ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_JELALI returns the epoch of the Jelali calendar as a JED. ! ! ! Modified: ! ! 24 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2114873.5D+00 return end subroutine epoch_to_jed_julian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_JULIAN returns the epoch of the Julian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1721423.5D+00 return end subroutine epoch_to_jed_khwarizmian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_KHWARIZMIAN returns the epoch of the Khwarizmian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! double precision jed ! jed = 1952067.5D+00 return end subroutine epoch_to_jed_macedonian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_MACEDONIAN returns the epoch of the Macedonian calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1607708.5D+00 return end subroutine epoch_to_jed_mayan_long ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_MAYAN_LONG returns the epoch of the Mayan long count calendar as a JED. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 584285.5D+00 return end subroutine epoch_to_jed_mjd ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_MJD returns the epoch of the MJD calendar as a JED. ! ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2400000.5D+00 return end subroutine epoch_to_jed_persian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_PERSIAN returns the epoch of the Persian calendar as a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1952062.5D+00 return end subroutine epoch_to_jed_republican ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_REPUBLICAN returns the epoch of the Republican calendar as a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2375839.5D+00 return end subroutine epoch_to_jed_roman ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ROMAN returns the epoch of the Roman calendar as a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! double precision jed ! jed = 1446389.5D+00 return end subroutine epoch_to_jed_saka ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_SAKA returns the epoch of the Saka calendar as a JED. ! ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1749994.5D+00 return end subroutine epoch_to_jed_soor_san ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1940352.5D+00 return end subroutine epoch_to_jed_syrian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_SYRIAN returns the epoch of the Syrian calendar as a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 1607738.5D+00 return end subroutine epoch_to_jed_unix ( jed ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2440587.50D+00 return end subroutine epoch_to_jed_y2k ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_Y2K returns the epoch of the Y2K calendar as a JED. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! implicit none ! double precision jed ! jed = 2451545.5D+00 return end subroutine epoch_to_jed_zoroastrian ( jed ) ! !******************************************************************************* ! !! EPOCH_TO_JED_ZOROASTRIAN returns the epoch of the Zoroastrian calendar as a JED. ! ! ! Modified: ! ! 21 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the epoch. ! double precision jed ! jed = 1579768.5D+00 return end subroutine frac_borrow_common ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d double precision f integer m integer 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 ) ! !******************************************************************************* ! !! 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, double precision F, ! the YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_common ( y, m, d ) return end subroutine frac_carry_english ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! the YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_english ( y, m, d ) return end subroutine frac_carry_gregorian ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_gregorian ( y, m, d ) return end subroutine frac_carry_hebrew ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_hebrew ( y, m, d ) return end subroutine frac_carry_islamic ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_islamic ( y, m, d ) return end subroutine frac_carry_julian ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_julian ( y, m, d ) return end subroutine frac_carry_republican ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! a YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_republican ( y, m, d ) return end subroutine frac_carry_roman ( y, m, d, f ) ! !******************************************************************************* ! !! 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, double precision F, ! the YMDF date. ! implicit none ! integer d integer days double precision f integer m integer y ! if ( f < 1.0D+00 ) then return end if days = int ( f ) f = f - dble ( days ) d = d + days call day_carry_roman ( y, m, d ) return end subroutine frac_to_hms ( f, h, m, s ) ! !******************************************************************************* ! !! FRAC_TO_HMS converts a fractional day into hours, minutes, seconds. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision 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 ! double precision f double precision f2 integer h integer m integer s ! f2 = f f2 = 24.0D+00 * f2 h = int ( f2 ) f2 = f2 - dble ( h ) f2 = 60.0D+00 * f2 m = int ( f2 ) f2 = f2 - dble ( m ) f2 = 60.0D+00 * f2 s = int ( f2 ) f2 = f2 - dble ( s ) return end subroutine frac_to_s ( f, s ) ! !******************************************************************************* ! !! FRAC_TO_S writes a positive fraction into a left justified character string. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision 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 ! double precision f character ( len = * ) s character ( len = 14 ) s2 ! write ( s2, '(f11.10)' ) f s = s2 return end subroutine hms_to_s ( h, n, second, s ) ! !******************************************************************************* ! !! 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 h integer i integer n integer second character ( len = * ) s character ( len = 8 ) s1 ! call i_to_s_zero ( h, s1(1:2) ) s1(3:3) = ':' call i_to_s_zero ( n, s1(4:5) ) s1(6:6) = ':' call i_to_s_zero ( second, s1(7:8) ) s = s1 return end subroutine hour_borrow_common ( y, m, d, h ) ! !******************************************************************************* ! !! 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 d integer h integer m integer 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 ) ! !******************************************************************************* ! !! HOUR_CARRY_COMMON is given a YMDH date, and carries hours to days. ! ! ! Algorithm: ! ! While H > 24: ! ! 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 d integer h integer m integer month_length_common integer y ! do while ( h > 24 ) h = h - 24 d = d + 1 call day_carry_common ( y, m, d ) end do return end function i_modp ( i, j ) ! !******************************************************************************* ! !! I_MODP returns the positive remainder when I is divided by J. ! ! ! Formula: ! ! NREM = I_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 I_MODP, the positive remainder when I is divided by J. ! implicit none ! integer i integer j integer i_modp ! if ( j == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_MODP - Fatal error!' write ( *, '(a,i6)' ) ' I_MODP ( I, J ) called with J = ', j stop end if i_modp = mod ( i, j ) if ( i_modp < 0 ) then i_modp = i_modp + abs ( j ) end if return end subroutine i_swap ( i, j ) ! !******************************************************************************* ! !! I_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 i integer j integer k ! k = i i = j j = k return end function i_to_a ( i ) ! !******************************************************************************* ! !! I_TO_A returns the I-th alphabetic character. ! ! ! Examples: ! ! I I_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 I_TO_A, the requested alphabetic letter. ! implicit none ! integer, parameter :: cap_shift = 64 integer, parameter :: low_shift = 96 ! integer i character i_to_a ! if ( i <= 0 ) then i_to_a = ' ' else if ( 1 <= i .and. i <= 26 ) then i_to_a = char ( cap_shift + i ) else if ( 27 <= i .and. i <= 52 ) then i_to_a = char ( low_shift + i - 26 ) else if ( i >= 53 ) then i_to_a = ' ' end if return end subroutine i_to_roman ( intval, s ) ! !******************************************************************************* ! !! I_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 icopy integer intval character ( len = * ) s ! s = ' ' icopy = intval if ( abs ( icopy ) > 4999 ) 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 ( icopy > 0 ) if ( icopy >= 1000 ) then call s_cat ( s, 'M', s ) icopy = icopy - 1000 else if ( icopy >= 900 ) then call s_cat ( s, 'CM', s ) icopy = icopy - 900 else if ( icopy >= 500 ) then call s_cat ( s, 'D', s ) icopy = icopy - 500 else if ( icopy >= 400 ) then call s_cat ( s, 'CD', s ) icopy = icopy - 400 else if ( icopy >= 100 ) then call s_cat ( s, 'C', s ) icopy = icopy - 100 else if ( icopy >= 90 ) then call s_cat ( s, 'XC', s ) icopy = icopy - 90 else if ( icopy >= 50 ) then call s_cat ( s, 'L', s ) icopy = icopy - 50 else if ( icopy >= 40 ) then call s_cat ( s, 'XL', s ) icopy = icopy - 40 else if ( icopy >= 10 ) then call s_cat ( s, 'X', s ) icopy = icopy - 10 else if ( icopy >= 9 ) then call s_cat ( s, 'IX', s ) icopy = icopy - 9 else if ( icopy >= 5 ) then call s_cat ( s, 'V', s ) icopy = icopy - 5 else if ( icopy >= 4 ) 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 i_to_s_left ( intval, s ) ! !******************************************************************************* ! !! I_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 i integer idig integer ihi integer ilo integer intval integer ipos integer 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 i_to_s_zero ( intval, s ) ! !******************************************************************************* ! !! I_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 i integer idig integer ihi integer ilo integer intval integer ipos integer 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 i_wrap ( ival, ilo, ihi ) ! !******************************************************************************* ! !! I_WRAP forces an integer to lie between given limits by wrapping. ! ! ! Example: ! ! ILO = 4, IHI = 8 ! ! I I_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: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, an integer value. ! ! Input, integer ILO, IHI, the desired bounds for the integer value. ! ! Output, integer I_WRAP, a "wrapped" version of IVAL. ! implicit none ! integer i_modp integer i_wrap integer ihi integer ilo integer ival integer wide ! wide = ihi + 1 - ilo if ( wide == 0 ) then i_wrap = ilo else i_wrap = ilo + i_modp ( ival-ilo, wide ) end if return end subroutine inflate_common ( y, m, d ) ! !******************************************************************************* ! !! 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 d integer m integer y ! if ( y == 1582 ) then if ( m == 10 ) then if ( d >= 5 ) then d = d + 10 end if end if end if return end subroutine inflate_english ( y, m, d ) ! !******************************************************************************* ! !! INFLATE_ENGLISH "inflates" 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 d integer m integer 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 ) ! !******************************************************************************* ! !! J_BORROW_COMMON borrows year-days from years in a Common date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_ENGLISH borrows year-days from years in an English date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_GREGORIAN borrows year-days from years in a Gregorian date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_HEBREW borrows year-days from years in a Hebrew date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_ISLAMIC borrows year-days from years in an Islamic date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_JULIAN borrows year-days from years in a Julian date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_REPUBLICAN borrows year-days from years in a Republican date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_BORROW_ROMAN borrows year-days from years in a Roman date. ! ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_COMMON carries year-days to years in a Common date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_ENGLISH carries year-days to years in an English date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_GREGORIAN carries year-days to years in a Gregorian date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_HEBREW carries year-days to years in a Hebrew date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_ISLAMIC carries year-days to years in an Islamic date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_JULIAN carries year-days to years in a Julian date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_REPUBLICAN carries year-days to years in a Republican date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! J_CARRY_ROMAN carries year-days to years in a Roman date. ! ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, a YJ date. ! implicit none ! integer days integer j integer y integer 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 ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date. ! ! Output, integer IERROR, is 0 if JED is legal, and 1 otherwise. ! implicit none ! integer ierror double precision jed if ( jed >= 0.0D+00 ) then ierror = 0 else ierror = 1 end if return end subroutine jed_test ( i, jed ) ! !******************************************************************************* ! !! JED_TEST returns some "interesting" JED's. ! ! ! Reference: ! ! Blackburn and Holford-Strevens, ! The Oxford Companion to the Year, ! Oxford, 1999. ! ! Frank Parise, editor, ! The Book of Calendars, ! Facts on File, Inc, 1982, ! CE11.K4 / 529.3. ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the test date requested. ! ! Output, double precision 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 i double precision jed ! ! JED Epoch: ! Beginning of current Scaliger cycle. ! Noon, 1 January 4713 BCE ! if ( i == 1 ) then call epoch_to_jed_jed ( jed ) ! ! The day after that. ! Noon, 2 January 4713 BCE ! else if ( i == 2 ) then call epoch_to_jed_jed ( jed ) jed = jed + 1.0D+00 ! ! Bishop James Ussher's estimate of the date of Creation, ! 9AM, 23 October 4004 BCE ! else if ( i == 3 ) then jed = 259258.25D+00 ! ! Hebrew Epoch. ! 7 October 3761 BCE ! else if ( i == 4 ) then call epoch_to_jed_hebrew ( jed ) ! ! Mayan Long Count Epoch. ! 8 September 3113 BCE ! 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 ! else if ( i == 6 ) then call epoch_to_jed_hindu_solar ( jed ) ! ! Chinese Epoch. ! 8 March 2637 BCE ! else if ( i == 7 ) then call epoch_to_jed_chinese ( jed ) ! ! Greek Olympiad Epoch ! 9 July 776 BCE ! else if ( i == 8 ) then call epoch_to_jed_greek ( jed ) ! ! Roman Epoch ! Ab Urbe Condita ! 1 January 753 BCE ! else if ( i == 9 ) then call epoch_to_jed_roman ( jed ) ! ! Egyptian Civil Calendar Epoch. ! 20 April 747 BCE ! else if ( i == 10 ) then call epoch_to_jed_eg_civil ( jed ) ! ! Zoroastrian Epoch. ! 3 March 388 BCE ! else if ( i == 11 ) then call epoch_to_jed_zoroastrian ( jed ) ! ! Macedonian Epoch ! 1 September 312 BCE ! else if ( i == 12 ) then call epoch_to_jed_macedonian ( jed ) ! ! Syrian Epoch ! 1 October 312 BCE ! else if ( i == 13 ) then call epoch_to_jed_syrian ( jed ) ! ! Alexandrian Epoch ! 29 August 23 BCE ! else if ( i == 14 ) then call epoch_to_jed_alexandrian ( jed ) ! ! Julian Epoch ! 1 January 1 CE ! else if ( i == 15 ) then call epoch_to_jed_julian ( jed ) ! ! Gregorian Epoch ! 3 January 1 CE ! else if ( i == 16 ) then call epoch_to_jed_gregorian ( jed ) ! ! Ethiopian Epoch ! 29 August 7 CE ! else if ( i == 17 ) then call epoch_to_jed_ethiopian ( jed ) ! ! Saka Epoch ! 4 March 79 CE ! else if ( i == 18 ) then call epoch_to_jed_saka ( jed ) ! ! Coptic Epoch ! 29 August 284 CE ! else if ( i == 19 ) then call epoch_to_jed_coptic ( jed ) ! ! Armenian Epoch ! 11 July 552 CE ! else if ( i == 20 ) then call epoch_to_jed_armenian ( jed ) ! ! Fasli Deccan Epoch ! 12 July 590 CE ! else if ( i == 21 ) then call epoch_to_jed_deccan ( jed ) ! ! Fasli Soor San Epoch ! 24 May 600 CE ! else if ( i == 22 ) then call epoch_to_jed_soor_san ( jed ) ! ! Islamic A Epoch ! 15 July 622 CE ! else if ( i == 23 ) then call epoch_to_jed_islamic_a ( jed ) ! ! Islamic B Epoch ! 16 July 622 CE ! else if ( i == 24 ) then call epoch_to_jed_islamic_b ( jed ) ! ! Persian Epoch ! Yezdezred Epoch ! 16 June 632 CE ! else if ( i == 25 ) then call epoch_to_jed_persian ( jed ) ! ! Khwarizmian Epoch ! 21 June 632 CE ! else if ( i == 26 ) then call epoch_to_jed_khwarizmian ( jed ) ! ! Jelali Epoch ! 17 March 1078 CE ! else if ( i == 27 ) then call epoch_to_jed_jelali ( jed ) ! ! Akbar Epoch ! 9 February 1556 CE ! 19 February 1556 (Gregorian) ! else if ( i == 28 ) then call epoch_to_jed_akbar ( jed ) ! ! Common calendar ! Noon of the last day of Julian calendar usage. ! 04 October 1582 Julian/CE ! 14 October 1582 Gregorian ! else if ( i == 29 ) then call transition_to_jed_common ( jed ) jed = jed - 0.5D+00 ! ! Common calendar ! Noon of the first day of Gregorian calendar usage. ! 05 October 1582 Julian ! 15 October 1582 Gregorian/CE ! else if ( i == 30 ) then call transition_to_jed_common ( jed ) jed = jed + 0.5D+00 ! ! English calendar ! noon of the last day of Julian calendar usage. ! 02 September 1752 Julian/English ! 13 September 1752 Gregorian/CE ! else if ( i == 31 ) 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 Gregorian/CE/English ! else if ( i == 32 ) then call transition_to_jed_english ( jed ) jed = jed + 0.5D+00 ! ! Republican Epoch ! 11 September 1792 (Julian) ! 22 September 1792 CE ! else if ( i == 33 ) then call epoch_to_jed_republican ( jed ) ! ! Bahai Epoch. ! 11 May 1844 (Julian) ! 23 May 1844 CE ! else if ( i == 34 ) then call epoch_to_jed_bahai ( jed ) ! ! Modified Julian Date Epoch. ! 17 November 1858 CE ! else if ( i == 35 ) then call epoch_to_jed_mjd ( jed ) ! ! Bessel Year Count Epoch. ! ? ? 1900 CE ! else if ( i == 36 ) then call epoch_to_jed_bessel ( jed ) ! ! UNIX epoch. ! 1 January 1970 CE. ! else if ( i == 37 ) then call epoch_to_jed_unix ( jed ) ! ! GPS epoch. ! 6 January 1980 CE ! else if ( i == 38 ) then call epoch_to_jed_gps ( jed ) ! ! Y2K day ! 1 January 2000 CE ! else if ( i == 39 ) then call epoch_to_jed_y2k ( jed ) ! ! End of Current Mayan Great Cycle ! 23 December 2012 CE ! else if ( i == 40 ) then call transition_to_jed_mayan_long ( jed ) ! ! Scaliger cycle repeats. ! 1 January 3266 CE ! else if ( i == 41 ) 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 ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date. ! ! Output, integer C, integer W, double precision S, the corresponding GPS ! cycles/weeks/seconds date. ! implicit none ! integer c double precision d double precision jed double precision jed_epoch integer w double precision 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 - dble ( 7 * w ) c = w / 1024 w = w - 1024 * c s = d * dble ( 24.0D+00 * 60.0D+00 * 60.0D+00 ) return end subroutine jed_to_mayan_long ( jed, pictun, baktun, katun, tun, uinal, kin, f ) ! !******************************************************************************* ! !! JED_TO_MAYAN_LONG converts a JED to a Mayan long count date. ! ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, chapter 27. ! ! Modified: ! ! 06 June 2001 ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer PICTUN, BAKTUN, KATUN, TUN, UINAL, KIN, values ! defining the Mayan long date. ! ! Output, double precision F, the fractional part of the date. ! implicit none ! integer baktun integer days double precision f integer j double precision jed double precision jed_epoch integer katun integer kin integer pictun integer tun integer uinal ! call epoch_to_jed_mayan_long ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) days = j if ( days >= 0 ) 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 ) ! !******************************************************************************* ! !! JED_TO_MAYAN_ROUND converts a JED to a Mayan round date. ! ! ! Reference: ! ! E G Richards, ! Algorithm K, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 340. ! ! Modified: ! ! 06 June 2001 ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, A, B, C, D, values defining the Mayan round date. ! ! Output, double precision F, the fractional part of the date. ! implicit none ! integer a integer b integer c integer d integer days double precision f integer i_wrap integer j double precision jed double precision jed_epoch integer n integer y ! call epoch_to_jed_mayan_long ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) 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 = i_wrap ( days + 4, 1, 13 ) b = i_wrap ( days, 1, 20 ) n = mod ( days + 348, 365 ) c = mod ( n, 20 ) d = n / 20 return end subroutine jed_to_mjd ( jed, mjd ) ! !******************************************************************************* ! !! JED_TO_MJD converts a JED to a modified JED. ! ! ! Modified: ! ! 11 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, double precision MJD, the modified Julian Ephemeris Date. ! implicit none ! double precision jed double precision jed_epoch double precision mjd ! call epoch_to_jed_mjd ( jed_epoch ) mjd = jed - jed_epoch return end subroutine jed_to_ss_unix ( jed, s ) ! !******************************************************************************* ! !! JED_TO_SS_UNIX converts a JED to a UNIX SS date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, double precision S, the corresponding UNIX SS date. ! implicit none ! double precision d double precision jed double precision jed_epoch double precision s ! call epoch_to_jed_unix ( jed_epoch ) d = jed - jed_epoch s = d * dble ( 24.0D+00 * 60.0D+00 * 60.0D+00 ) return end subroutine jed_to_weekday ( jed, w, f ) ! !******************************************************************************* ! !! JED_TO_WEEKDAY computes the day of the week from a JED. ! ! ! Discussion: ! ! BC 4713/01/01 => JED = 0 was noon on a Monday. ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision 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, double precision F, the fractional part of the day. ! implicit none ! double precision f integer i_wrap integer j double precision jed integer w ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) w = i_wrap ( j + 1, 1, 7 ) return end subroutine jed_to_year_hebrew ( jed, y ) ! !******************************************************************************* ! !! JED_TO_YEAR_HEBREW determines the year in the Hebrew calendar when a JED occurred. ! ! ! Reference: ! ! E G Richards, ! Algorithm H, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 331. ! ! Modified: ! ! 15 March 2001 ! ! Parameters: ! ! Input, double precision 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 i_modp double precision jed double precision jed2 double precision jed_epoch integer m integer 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 * ( i_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 ( jed2 > jed ) then y = y - 1 end if return end subroutine jed_to_yearcount_bessel ( jed, bessel ) ! !******************************************************************************* ! !! JED_TO_YEARCOUNT_BESSEL converts a JED to Bessel year count. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, double precision BESSEL, the Bessel year. ! implicit none ! double precision bessel double precision jed double precision jed_epoch double precision, 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 ) ! !******************************************************************************* ! !! 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, double precision JED, the Julian Ephemeris Date. ! ! Output, double precision JULIAN, the Julian year. ! implicit none ! double precision jed double precision jed_epoch double precision julian double precision, 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_COMMON converts a JED to a Common YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_ENGLISH converts a JED to an English YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_GREGORIAN converts a JED to a Gregorian YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_HEBREW converts a JED to a Hebrew YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_ISLAMIC_A converts a JED to an Islamic-A YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_ISLAMIC_B converts a JED to an Islamic-B YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_JULIAN converts a JED to a Julian YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_REPUBLICAN converts a JED to a Republican YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer 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 ) ! !******************************************************************************* ! !! JED_TO_YJF_ROMAN converts a JED to a Roman YJF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! integer d1 double precision f double precision f1 integer j double precision jed integer m1 integer y integer y1 ! call jed_to_ymdf_roman ( jed, y1, m1, d1, f1 ) call ymdf_to_yjf_roman ( y1, m1, d1, f1, y, j, f ) return end subroutine jed_to_ymdf_alexandrian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ALEXANDRIAN converts a JED to an Alexandrian YMDF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 124 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 4690 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_armenian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ARMENIAN converts a JED to an Armenian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 317 y_prime = j_prime / 365 t_prime = mod ( j_prime, 365 ) m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 5268 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_bahai ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_BAHAI converts a JED to a Bahai YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime integer g double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) g = 3 * ( ( 4 * j + 274273 ) / 146097 ) / 4 - 50 j_prime = j + 1412 + g y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = t_prime / 19 d_prime = mod ( t_prime, 19 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 19, 20 ) + 1 y = y_prime - 6560 + ( 39 - m ) / 20 return end subroutine jed_to_ymdf_common ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_COMMON converts a JED to a Common YMDF date. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! JED = 2299160.5, and Gregorian thereafter. ! ! There is no year 0. BC years are specified using a negative value. ! ! Examples: ! ! JED Y M D ! ------- ------------------ ! 0 BCE 4713 Jan 1 ! 2440000 CE 1968 May 23 ! 2446065 CE 1984 Dec 31 ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integr M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f double precision jed double precision jed_transition integer m integer y ! call transition_to_jed_common ( jed_transition ) if ( jed <= jed_transition ) then call jed_to_ymdf_julian ( jed, y, m, d, f ) else call jed_to_ymdf_gregorian ( jed, y, m, d, f ) end if return end subroutine jed_to_ymdf_coptic ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_COPTIC converts a JED to a Coptic YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 124 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 4996 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_eg_civil ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_EG_CIVIL converts a JED to an Egyptian Civil YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 47 - 1 y_prime = j_prime / 365 t_prime = mod ( j_prime, 365 ) m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 3968 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_eg_lunar ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_EG_LUNAR converts a JED to an Egyptian Lunar YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer j double precision jed double precision jed_epoch integer m integer month_length_eg_lunar integer ncycle integer y integer year_length_eg_lunar ! call epoch_to_jed_eg_lunar ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) d = 1 + j m = 1 y = 1 ! ! Account for the number of 25 year cycles of 9125 days. ! ncycle = d / 9125 y = y + 25 * ncycle d = d - ncycle * 9125 do while ( d > year_length_eg_lunar ( y ) ) d = d - year_length_eg_lunar ( y ) y = y + 1 end do do while ( d > month_length_eg_lunar ( y, m ) ) d = d - month_length_eg_lunar ( y, m ) m = m + 1 end do return end subroutine jed_to_ymdf_english ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ENGLISH converts a JED to an English YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f double precision jed double precision jed_transition integer m integer y ! call transition_to_jed_english ( jed_transition ) if ( jed <= jed_transition ) then call jed_to_ymdf_julian ( jed, y, m, d, f ) else call jed_to_ymdf_gregorian ( jed, y, m, d, f ) end if return end subroutine jed_to_ymdf_ethiopian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ETHIOPIAN converts a JED to an Ethiopian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 124 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 4720 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_gregorian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_GREGORIAN converts a JED to a Gregorian YMDF date. ! ! ! Note: ! ! This Gregorian calendar is extended backwards in time before ! its actual adoption. ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer g integer j double precision jed double precision jed2 integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) g = 3 * ( ( 4 * j + 274277 ) / 146097 ) / 4 - 38 j_prime = j + 1401 + g y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = ( 5 * t_prime + 2 ) / 153 d_prime = mod ( 5 * t_prime + 2, 153 ) / 5 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 2, 12 ) + 1 y = y_prime - 4716 + ( 14 - m ) / 12 ! ! Any year before 1 AD must be moved one year further back, since ! this calendar does not include a year 0. ! call y_astronomical_to_common ( y, y ) return end subroutine jed_to_ymdf_gregorian2 ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_GREGORIAN2 converts a JED to a Gregorian YMDF date. ! ! ! Discussion: ! ! The theory behind this routine is very clean. The Gregorian ! calendar has cycles of 1, 4, 100 and 400 years, and we can ! analyze a date by determining where it lies within these cycles. ! ! Reference: ! ! E Reingold, N Dershowitz, S Clamen, ! Calendrical Calculations, II: Three Historical Calendars, ! Software - Practice and Experience, ! Volume 23, Number 4, pages 383-404, April 1993. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d0 integer d1 integer d2 integer d3 integer d4 double precision f double precision f1 integer, parameter :: g1 = 365 integer, parameter :: g4 = 1461 integer, parameter :: g100 = 36524 integer, parameter :: g400 = 146097 integer i_modp integer j double precision jed double precision jed_epoch integer j1 integer m integer n1 integer n4 integer n100 integer n400 integer y integer y1 ! call epoch_to_jed_gregorian ( jed_epoch ) j = int ( jed - jed_epoch ) f1 = ( jed - jed_epoch ) - dble ( j ) d0 = j n400 = 0 do while ( d0 < 0 ) d0 = d0 + g400 n400 = n400 - 1 end do n400 = n400 + d0 / g400 d1 = i_modp ( d0, g400 ) n100 = d1 / g100 d2 = i_modp ( d1, g100 ) n4 = d2 / g4 d3 = i_modp ( d2, g4 ) n1 = d3 / g1 d4 = i_modp ( d3, g1 ) if ( n100 == 4 .or. n1 == 4 ) then j1 = 366 y1 = 400 * n400 + 100 * n100 + 4 * n4 + n1 else j1 = d4 + 1 y1 = 400 * n400 + 100 * n100 + 4 * n4 + n1 + 1 end if ! ! Any year before 1 AD must be moved one year further back, since ! this calendar does not include a year 0. ! call y_astronomical_to_common ( y1, y1 ) call yjf_to_ymdf_gregorian ( y1, j1, f1, y, m, d, f ) return end subroutine jed_to_ymdf_hebrew ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_HEBREW converts a JED to a Hebrew YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm I, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 334. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f double precision f1 integer j1 double precision jed double precision jed2 integer m integer type integer y integer y1 ! call jed_to_year_hebrew ( jed, y1 ) call new_year_to_jed_hebrew ( y1, jed2 ) call year_to_type_hebrew ( y1, type ) j1 = int ( jed - jed2 ) f1 = ( jed - jed2 ) - dble ( j1 ) j1 = j1 + 1 call yjf_to_ymdf_hebrew ( y1, j1, f1, y, m, d, f ) return end subroutine jed_to_ymdf_hindu_solar ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_HINDU_SOLAR converts a JED to a Hindu solar YMDF date. ! ! ! Reference: ! ! E Reingold, N Dershowitz, S Clamen, ! Calendrical Calculations, II: Three Historical Calendars, ! Software - Practice and Experience, ! Volume 23, Number 4, pages 383-404, April 1993. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer j double precision jed double precision jed_epoch integer m double precision month_length_hindu_solar integer y double precision year_length_hindu_solar ! call epoch_to_jed_hindu_solar ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) y = int ( dble ( j ) / year_length_hindu_solar ( ) ) j = j - int ( dble ( y ) * year_length_hindu_solar ( ) ) m = 1 + int ( dble ( j ) / month_length_hindu_solar ( ) ) j = j - int ( dble ( m - 1 ) * month_length_hindu_solar ( ) ) d = 1 + j return end subroutine jed_to_ymdf_islamic_a ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ISLAMIC_A converts a JED to an Islamic A YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 7665 y_prime = ( 30 * j_prime + 15 ) / 10631 t_prime = mod ( 30 * j_prime + 15, 10631 ) / 30 m_prime = ( 100 * t_prime + 10 ) / 2951 d_prime = mod ( 100 * t_prime + 10, 2951 ) / 100 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 12 ) + 1 y = y_prime - 5519 + ( 12 - m ) / 12 return end subroutine jed_to_ymdf_islamic_b ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ISLAMIC_B converts a JED to an Islamic B YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 7664 y_prime = ( 30 * j_prime + 15 ) / 10631 t_prime = mod ( 30 * j_prime + 15, 10631 ) / 30 m_prime = ( 100 * t_prime + 10 ) / 2951 d_prime = mod ( 100 * t_prime + 10, 2951 ) / 100 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 12 ) + 1 y = y_prime - 5519 + ( 12 - m ) / 12 return end subroutine jed_to_ymdf_jelali ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_JELALI converts a JED to a Jelali YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer j double precision jed double precision jed_epoch integer m integer n integer y ! call epoch_to_jed_jelali ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) d = 1 + j m = 1 y = 1 ! ! Account for the number of completed 4 year cycles of 1461 days. ! n = ( d - 1 ) / 1461 y = y + 4 * n d = d - n * 1461 ! ! Account for the number of completed 365 day years. ! n = ( d - 1 ) / 365 y = y + n d = d - n * 365 ! ! Account for the number of completed 30 day months. ! n = ( d - 1 ) / 30 m = m + n d = d - n * 30 return end subroutine jed_to_ymdf_julian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_JULIAN converts a JED to a Julian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 1401 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = ( 5 * t_prime + 2 ) / 153 d_prime = mod ( 5 * t_prime + 2, 153 ) / 5 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 2, 12 ) + 1 y = y_prime - 4716 + ( 14 - m ) / 12 ! ! Any year before 1 AD must be moved one year further back, since ! this calendar does not include a year 0. ! call y_astronomical_to_common ( y, y ) return end subroutine jed_to_ymdf_julian2 ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_JULIAN2 converts a JED to a Julian YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer ierror integer j integer jd integer je double precision jed integer jg integer m integer y ! ! Check the input. ! call jed_check ( jed, ierror ) if ( ierror /= 0 ) then y = -1 m = -1 d = -1 f = -1.0D+00 return end if j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) jd = int ( ( dble ( j + 1524 ) - 122.1 ) / 365.25 ) je = int ( 365.25 * dble ( jd ) ) jg = int ( dble ( j + 1524 - je ) / 30.6001 ) ! ! Now compute D, M and Y. ! d = j + 1524 - je - int ( 30.6001 * jg ) if ( jg <= 13 ) then m = jg - 1 else m = jg - 13 end if if ( m > 2 ) then y = jd - 4716 else y = jd - 4715 end if ! ! Any year before 1 AD must be moved one year further back, since ! this calendar does not include a year 0. ! call y_astronomical_to_common ( y, y ) return end subroutine jed_to_ymdf_julian3 ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_JULIAN3 converts a JED to a Julian YMDF date. ! ! ! Discussion: ! ! The theory behind this routine is very clean. The Julian ! calendar has cycles of 1 and 4 years, and we can analyze a date ! by determining where it lies within these cycles. ! ! Reference: ! ! E Reingold, N Dershowitz, S Clamen, ! Calendrical Calculations, II: Three Historical Calendars, ! Software - Practice and Experience, ! Volume 23, Number 4, pages 383-404, April 1993. ! ! Modified: ! ! 18 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer, parameter :: cycle_length = 1461 integer d integer d0 integer d1 integer d2 double precision f double precision f1 integer i_modp integer j integer j1 double precision jed double precision jed_epoch integer m integer n1 integer n4 integer y integer y1 integer, parameter :: year_length = 365 ! call epoch_to_jed_julian ( jed_epoch ) j = int ( jed - jed_epoch ) f1 = ( jed - jed_epoch ) - dble ( j ) if ( f1 < 0.0D+00 ) then f1 = f1 + 1.0D+00 j = j - 1 end if d0 = j n4 = 0 do while ( d0 <= 0 ) d0 = d0 + cycle_length n4 = n4 - 1 end do n4 = n4 + d0 / cycle_length d1 = i_modp ( d0, cycle_length ) n1 = d1 / year_length d2 = i_modp ( d1, year_length ) if ( n1 == 4 ) then j1 = 366 y1 = 4 * n4 + n1 else j1 = d2 + 1 y1 = 4 * n4 + n1 + 1 end if ! ! Any year before 1 AD must be moved one year further back, since ! this calendar does not include a year 0. ! call y_astronomical_to_common ( y1, y1 ) call yjf_to_ymdf_julian ( y1, j1, f1, y, m, d, f ) return end subroutine jed_to_ymdf_khwarizmian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_KHWARIZMIAN converts a JED to a Khwarizmian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - j j_prime = j + 317 y_prime = j_prime / 365 t_prime = mod ( j_prime, 365 ) m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 5348 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_macedonian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_MACEDONIAN converts a JED to a Macedonian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 1401 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = ( 5 * t_prime + 2 ) / 153 d_prime = mod ( 5 * t_prime + 2, 153 ) / 5 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 6, 12 ) + 1 y = y_prime - 4405 + ( 18 - m ) / 12 return end subroutine jed_to_ymdf_persian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_PERSIAN converts a JED to a Persian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 77 y_prime = j_prime / 365 t_prime = mod ( j_prime, 365 ) m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 9, 13 ) + 1 y = y_prime - 5348 + ( 22 - m ) / 13 return end subroutine jed_to_ymdf_republican ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_REPUBLICAN converts a JED to a Republican YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer g integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) g = 3 * ( ( 4 * j + 578797 ) / 146097 ) / 4 - 51 j_prime = j + 111 + g y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = t_prime / 30 d_prime = mod ( t_prime, 30 ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime, 13 ) + 1 y = y_prime - 6504 + ( 13 - m ) / 13 return end subroutine jed_to_ymdf_roman ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ROMAN converts a JED to a Roman YMDF date. ! ! ! Discussion: ! ! The Roman calendar used here is artificial. It is assumed to begin ! on the Julian calendar date 1 January 753 BC, and to be simply a ! copy of the Julian calendar, shifted by 753 years. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f double precision jed integer m integer y integer yj ! call jed_to_ymdf_julian ( jed, yj, m, d, f ) call y_julian_to_roman ( yj, y ) return end subroutine jed_to_ymdf_saka ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_SAKA converts a JED to a Saka YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer g integer j double precision jed integer j_prime integer m integer m_prime integer s integer t_prime integer x integer y integer y_prime integer z ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) g = 3 * ( ( 4 * j + 274073 ) / 146097 ) / 4 - 36 j_prime = j + 1348 + g y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 x = t_prime / 365 z = t_prime / 185 - x s = 31 - z m_prime = ( t_prime - 5 * z ) / s d_prime = 6 * x + mod ( t_prime - 5 * z, s ) ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 1, 12 ) + 1 y = y_prime - 4794 + ( 13 - m ) / 12 return end subroutine jed_to_ymdf_soor_san ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_SOOR_SAN converts a JED to a Soor San YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer j double precision jed double precision jed_epoch integer m integer n integer y ! call epoch_to_jed_soor_san ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) d = 1 + j m = 1 y = 1 ! ! Account for the number of completed 4 year cycles of 1461 days. ! n = ( d - 1 ) / 1461 y = y + 4 * n d = d - n * 1461 ! ! Account for the number of completed 365 day years. ! n = ( d - 1 ) / 365 y = y + n d = d - n * 365 ! ! Account for the number of completed 30 day months. ! n = ( d - 1 ) / 30 m = m + n d = d - n * 30 return end subroutine jed_to_ymdf_syrian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_SYRIAN converts a JED to a Syrian YMDF date. ! ! ! Reference: ! ! E G Richards, ! Algorithm F, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 324-325. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d integer d_prime double precision f integer j double precision jed integer j_prime integer m integer m_prime integer t_prime integer y integer y_prime ! ! Determine the computational date (Y'/M'/D'). ! j = int ( jed + 0.5D+00 ) f = ( jed + 0.5D+00 ) - dble ( j ) j_prime = j + 1401 y_prime = ( 4 * j_prime + 3 ) / 1461 t_prime = mod ( 4 * j_prime + 3, 1461 ) / 4 m_prime = ( 5 * t_prime + 2 ) / 153 d_prime = mod ( 5 * t_prime + 2, 153 ) / 5 ! ! Convert the computational date to a calendar date. ! d = d_prime + 1 m = mod ( m_prime + 5, 12 ) + 1 y = y_prime - 4405 + ( 17 - m ) / 12 return end subroutine jed_to_ymdf_zoroastrian ( jed, y, m, d, f ) ! !******************************************************************************* ! !! JED_TO_YMDF_ZOROASTRIAN converts a JED to a Zoroastrian YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision JED, the Julian Ephemeris Date. ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d double precision f integer j double precision jed double precision jed_epoch integer m integer months integer y integer years ! call epoch_to_jed_zoroastrian ( jed_epoch ) j = int ( jed - jed_epoch ) f = ( jed - jed_epoch ) - dble ( j ) d = 1 + j m = 1 y = 1 years = ( d - 1 ) / 365 y = y + years d = d - years * 365 months = ( d - 1 ) / 30 m = m + months d = d - months * 30 return end function lower ( s ) ! !******************************************************************************* ! !! LOWER returns a lowercase version of a string. ! ! ! Discussion: ! ! LOWER is a string function of undeclared length. The length ! of the argument returned is determined by the declaration of ! LOWER in the calling routine. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string. ! ! Output, character ( len = * ) LOWER, a lowercase copy of the string. ! implicit none ! integer i integer j character ( len = * ) lower integer n character ( len = * ) s ! lower = s n = len_trim ( lower ) do i = 1, n j = ichar ( lower(i:i) ) if ( 65 <= j .and. j <= 90 ) then lower(i:i) = char ( j + 32 ) end if end do return end subroutine mayan_long_to_jed ( pictun, baktun, katun, tun, uinal, kin, f, jed ) ! !******************************************************************************* ! !! MAYAN_ROUND_TO_JED converts a Mayan round date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm L, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 341. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PICTUN, BAKTUN, KATUN, TUN, UINAL, KIN, values ! defining the Mayan long date. ! ! Input, double precision F, the fractional part of the date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer baktun integer days double precision f double precision jed double precision jed_epoch integer katun integer kin integer pictun integer tun integer uinal ! days = ((((( pictun * 20 + baktun ) * 20 + katun ) * 20 & + tun ) * 18 + uinal ) * 20 + kin ) call epoch_to_jed_mayan_long ( jed_epoch ) jed = jed_epoch + dble ( days ) + f return end subroutine mayan_round_to_jed ( y, a, b, c, d, f, jed ) ! !******************************************************************************* ! !! MAYAN_ROUND_TO_JED converts a Mayan round date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm L, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 341. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, A, B, C, D, values defining the Mayan round date. ! ! Input, double precision F, the fractional part of the date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer a integer b integer c integer d double precision f integer i_modp double precision jed double precision jed_epoch integer m integer n integer r integer y ! m = 13 * i_modp ( 60 + 3 * ( a - b ), 20 ) + a - 1 m = i_modp ( m + 101, 260 ) n = 20 * d + c n = i_modp ( n + 17, 365 ) r = 365 * i_modp ( 364 + m - n, 52 ) + n call epoch_to_jed_mayan_long ( jed_epoch ) jed = jed_epoch + dble ( 18980 * y + r ) + f return end subroutine minute_borrow_common ( y, m, d, h, n ) ! !******************************************************************************* ! !! MINUTE_BORROW_COMMON "borrows" an hour of minutes in a Common date. ! ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, N, the year, ! month, day, hour and minute representing a date. On input, N ! might be negative. ! On output, H should have decreased by one, and N gone up by 60. ! implicit none ! integer d integer h integer m integer n integer y ! do while ( n < 0 ) n = n + 60 h = h - 1 call hour_borrow_common ( y, m, d, h ) end do return end subroutine minute_carry_common ( y, m, d, h, n ) ! !******************************************************************************* ! !! MINUTE_CARRY_COMMON is given a Common YMDHMS date, and carries minutes to hours. ! ! ! Algorithm: ! ! While N >= 60: ! ! decrease N by the number of minutes in an hour; ! increase H by 1; ! if necessary, adjust Y, M and D. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, N, the date. ! On output, N is between 0 and 59. ! implicit none ! integer d integer h integer m integer n integer y ! do while ( n >= 60 ) n = n - 60 h = h + 1 call hour_carry_common ( y, m, d, h ) end do return end subroutine mjd_to_jed ( mjd, jed ) ! !******************************************************************************* ! !! MJD_TO_JED converts a modified JED to a JED. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision MJD, the modified Julian Ephemeris Date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! double precision jed double precision jed_epoch double precision mjd ! call epoch_to_jed_mjd ( jed_epoch ) jed = mjd + jed_epoch return end subroutine month_borrow_alexandrian ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_ALEXANDRIAN borrows a year of months on the Alexandrian calendar. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! On input, M might be negative. On output, Y should have decreased by ! one, and M gone up by the number of months in the year that we ! "cashed in". The routine knows there was no year 0. ! implicit none ! integer m integer months integer y integer year_length_months_alexandrian ! do while ( m <= 0 ) months = year_length_months_alexandrian ( y ) m = m + months y = y - 1 end do return end subroutine month_borrow_common ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_COMMON borrows a year of months on the Common calendar. ! ! ! Discussion: ! ! If the month index is legal, nothing is done. If the month index ! is too small, then one or more years are "cashed in" to bring the ! month index up to a legal value. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! On input, M might be negative. On output, Y should have decreased by ! one, and M gone up by the number of months in the year that we ! "cashed in". The routine knows there was no year 0. ! implicit none ! integer m integer months integer y integer year_length_months_common ! do while ( m <= 0 ) months = year_length_months_common ( y ) m = m + months y = y - 1 if ( y == 0 ) then y = - 1 end if end do return end subroutine month_borrow_eg_civil ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_EG_CIVIL borrows a year of months on the Egyptian Civil calendar. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_eg_civil ! do while ( m <= 0 ) months = year_length_months_eg_civil ( y ) m = m + months y = y - 1 end do return end subroutine month_borrow_english ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_ENGLISH borrows a year of months on the English calendar. ! ! ! Discussion: ! ! If the month index is legal, nothing is done. If the month index ! is too small, then one or more years are "cashed in" to bring the ! month index up to a legal value. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_english ! do while ( m <= 0 ) months = year_length_months_english ( y ) m = m + months y = y - 1 if ( y == 0 ) then y = - 1 end if end do return end subroutine month_borrow_gregorian ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_GREGORIAN borrows a year of months on the Gregorian calendar. ! ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_gregorian ! do while ( m <= 0 ) months = year_length_months_gregorian ( y ) m = m + months y = y - 1 if ( y == 0 ) then y = - 1 end if end do return end subroutine month_borrow_hebrew ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_HEBREW borrows a year of months on the Hebrew calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_hebrew ! do while ( m <= 0 ) months = year_length_months_hebrew ( y ) m = m + months y = y - 1 end do return end subroutine month_borrow_islamic ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_ISLAMIC borrows a year of months on the Islamic calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_islamic ! do while ( m <= 0 ) months = year_length_months_islamic ( y ) m = m + months y = y - 1 end do return end subroutine month_borrow_julian ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_JULIAN borrows a year of months on the Julian calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_julian ! do while ( m <= 0 ) months = year_length_months_julian ( y ) m = m + months y = y - 1 if ( y == 0 ) then y = - 1 end if end do return end subroutine month_borrow_republican ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_REPUBLICAN borrows a year of months on the Republican calendar. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_republican ! do while ( m <= 0 ) months = year_length_months_republican ( y ) m = m + months y = y - 1 end do return end subroutine month_borrow_roman ( y, m ) ! !******************************************************************************* ! !! MONTH_BORROW_ROMAN borrows a year of months on the Roman calendar. ! ! ! Discussion: ! ! If the month index is legal, nothing is done. If the month index ! is too small, then one or more years are "cashed in" to bring the ! month index up to a legal value. ! ! Modified: ! ! 15 July ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_roman ! do while ( m <= 0 ) months = year_length_months_roman ( y ) m = m + months y = y - 1 if ( y == 0 ) then y = - 1 end if end do return end subroutine month_cal_common ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_COMMON prints a Common month calendar. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! Format: ! ! COMMON CALENDAR ! APRIL 1997 CE ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d integer d_max integer d2 double precision f double precision f2 integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_common character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_common ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_common ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_common ( m2, s1 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMON CALENDAR' call y_to_s_common ( y2, s2 ) write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! IDAY keeps track of the numerical day, ! D2 keeps track of the label for the day, which only differed ! from IDAY in October 1582. ! d2 = iday f2 = 0.0D+00 d_max = month_length_common ( y2, m2 ) do while ( iday <= d_max ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > d_max ) then label(w) = ' ' else write ( label(w), '(i2)' ) d2 end if iday = iday + 1 call ymdf_next_common ( y2, m2, d2, f2, y2, m2, d2, f2 ) end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_english ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_ENGLISH prints an English month calendar. ! ! ! Format: ! ! ENGLISH CALENDAR ! APRIL 1997 AD ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d integer d_max integer d2 double precision f double precision f2 integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_english character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_english ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_english ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_common ( m2, s1 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ENGLISH CALENDAR' call y_to_s_common ( y2, s2 ) write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! IDAY keeps track of the numerical day, ! D2 keeps track of the label for the day, which ! only differed from IDAY in September 1752. ! d2 = iday f2 = 0.0D+00 d_max = month_length_english ( y2, m2 ) do while ( iday <= d_max ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > d_max ) then label(w) = ' ' else write ( label(w), '(i2)' ) d2 end if iday = iday + 1 call ymdf_next_english ( y2, m2, d2, f2, y2, m2, d2, f2 ) end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_gregorian ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_GREGORIAN prints a Gregorian month calendar. ! ! ! Format: ! ! GREGORIAN CALENDAR ! APRIL 1997 AD ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 02 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d double precision f integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_gregorian character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_gregorian ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_gregorian ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_common ( m2, s1 ) call y_to_s_gregorian ( y, s2 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GREGORIAN CALENDAR' write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! do while ( iday <= month_length_gregorian ( y2, m2 ) ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > month_length_gregorian ( y2, m2 ) ) then label(w) = ' ' else write ( label(w), '(i2)' ) iday end if iday = iday + 1 end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_hebrew ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_HEBREW prints a Hebrew month calendar. ! ! ! Format: ! ! HEBREW CALENDAR ! month year AM ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d double precision f integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_hebrew character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_hebrew ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_hebrew ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_hebrew ( y2, m2, s1 ) call y_to_s_hebrew ( y, s2 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HEBREW CALENDAR' write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! do while ( iday <= month_length_hebrew ( y2, m2 ) ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > month_length_hebrew ( y2, m2 ) ) then label(w) = ' ' else write ( label(w), '(i2)' ) iday end if iday = iday + 1 end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_islamic_a ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_ISLAMIC_A prints an Islamic-A month calendar. ! ! ! Format: ! ! ISLAMIC-A CALENDAR ! month year AH ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d double precision f integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_islamic character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_islamic ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_islamic_a ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_islamic ( m2, s1 ) call y_to_s_islamic ( y, s2 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ISLAMIC-A CALENDAR' write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! do while ( iday <= month_length_islamic ( y2, m2 ) ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > month_length_islamic ( y2, m2 ) ) then label(w) = ' ' else write ( label(w), '(i2)' ) iday end if iday = iday + 1 end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_julian ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_JULIAN prints a Julian month calendar. ! ! ! Format: ! ! JULIAN CALENDAR ! APRIL 1997 AD ! ! Su M Tu W Th F Sa ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d double precision f integer iday integer ierror character ( len = 2 ) label(7) integer m integer m2 integer month_length_julian character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_julian ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y/M/1. ! d = 1 f = 0.0D+00 call ymdf_to_weekday_julian ( y2, m2, d, f, w ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a heading. ! call month_to_month_name_common ( m2, s1 ) call y_to_s_julian ( y, s2 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JULIAN CALENDAR' write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, label(w) ) end do write ( *, '(1x,7a3)' ) label(1:7) ! ! Print out a line of day numbers. ! do while ( iday <= month_length_julian ( y2, m2 ) ) do w = 1, 7 if ( iday < 1 ) then label(w) = ' ' else if ( iday > month_length_julian ( y2, m2 ) ) then label(w) = ' ' else write ( label(w), '(i2)' ) iday end if iday = iday + 1 end do write ( *, '(1x,7a3)' ) label(1:7) end do return end subroutine month_cal_republican ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_REPUBLICAN prints a Republican month calendar. ! ! ! Format: ! ! REPUBLICAN CALENDAR ! Brumaire 3 ER ! ! 1 2 3 4 5 6 7 8 9 10 ! 11 12 13 14 15 16 17 18 19 20 ! 21 22 23 24 25 26 27 28 29 30 ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d integer iday integer ierror character ( len = 2 ) label(10) integer m integer m2 integer month_length_republican character ( len = 15 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. ! call ym_check_republican ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Print out a heading. ! call month_to_month_name_republican ( m2, s1 ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'REPUBLICAN CALENDAR' call y_to_s_republican ( y2, s2 ) write ( *, '(a,1x,a)' ) trim ( s1 ), trim ( s2 ) write ( *, '(a)' ) ' ' ! ! Print out a line of day numbers. ! iday = 1 do while ( iday <= month_length_republican ( y2, m2 ) ) do w = 1, 10 if ( iday > month_length_republican ( y2, m2 ) ) then label(w) = ' ' else write ( label(w), '(i2)' ) iday end if iday = iday + 1 end do write ( *, '(1x,10a3)' ) label(1:10) end do return end subroutine month_cal_roman ( y, m ) ! !******************************************************************************* ! !! MONTH_CAL_ROMAN prints a Roman month calendar. ! ! ! Format: ! ! ROMAN CALENDAR ! Aprilis DVI AUC ! ! Kalends Aprilis ! Ante diem iv Nones Aprilis ! Ante diem iii Nones Aprilis ! Pridie Nones Aprilis ! Nones Aprilis ! Ante diem viii Ides Aprilis ! Ante diem vii Ides Aprilis ! Ante diem vi Ides Aprilis ! Ante diem v Ides Aprilis ! Ante diem iv Ides Aprilis ! Ante diem iii Ides Aprilis ! Pridie Ides Aprilis ! Ides Aprilis ! Ante diem xvii Kalends Maius ! Ante diem xvi Kalends Maius ! ... ! Ante diem iv Kalends Maius ! Ante diem iii Kalends Maius ! Pridie Kalends Maius ! ! Discussion: ! ! "AUC" means "ab urbe condita", or "from the founding of the city". ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! implicit none ! integer d integer i_wrap integer iday integer ides integer ierror integer jday integer last character ( len = 10 ) lower integer m integer m2 integer m3 integer month_length_roman integer nones character ( len = 40 ) s_date character ( len = 10 ) s_day character ( len = 15 ) s_month character ( len = 15 ) s_month_next character ( len = 10 ) s_year integer y integer y2 logical year_is_leap_roman ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. ! call ym_check_roman ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Print out a heading. ! call month_to_month_name_roman ( m2, s_month ) m3 = i_wrap ( m2+1, 1, 12 ) call month_to_month_name_roman ( m3, s_month_next ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ROMAN CALENDAR' call i_to_roman ( y2, s_year ) call s_cat ( s_year, ' AUC', s_year ) write ( *, '(a,1x,a)' ) trim ( s_month ), trim ( s_year ) write ( *, '(a)' ) ' ' call month_to_nones_roman ( m2, nones ) call month_to_ides_roman ( m2, ides ) last = month_length_roman ( y2, m2 ) do iday = 1, last if ( iday == 1 ) then s_date = 'Kalends ' // s_month else if ( iday < nones - 1 ) then jday = nones + 1 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem ' // trim ( s_day ) // ' Nones ' // s_month else if ( iday == nones - 1 ) then s_date = 'Pridie Nones ' // s_month else if ( iday == nones ) then s_date = 'Nones ' // s_month else if ( iday < ides - 1 ) then jday = ides + 1 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem ' // trim ( s_day ) // ' Ides ' // s_month else if ( iday == ides - 1 ) then s_date = 'Pridie Ides ' // s_month else if ( iday == ides ) then s_date = 'Ides ' // s_month else if ( m2 == 2 .and. year_is_leap_roman ( y2 ) ) then if ( iday < 25 ) then jday = last + 1 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( iday == 25 ) then jday = last + 2 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem Bis ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( iday < last ) then jday = last + 2 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s_date = 'Pridie Kalends ' // s_month_next end if else if ( iday < last ) then jday = last + 2 - iday call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s_date = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s_date = 'Pridie Kalends ' // s_month_next end if write ( *, '(a)' ) trim ( s_date ) end do return end subroutine month_cal_store_common ( y, m, lines ) ! !******************************************************************************* ! !! MONTH_CAL_STORE_COMMON stores a Common month calendar. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian before ! the transition date, and Gregorian afterwards, with the transition date ! best specified as as JED = 2299160. ! ! Format: ! ! 1 2 3 4 5 ! 6 7 8 9 10 11 12 ! 13 14 15 16 17 18 19 ! 20 21 22 23 24 25 26 ! 27 28 29 30 ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the YM date. ! ! Output, character ( len = 20 ) LINES(6), the six lines of the calendar. ! implicit none ! integer d integer days integer d2 double precision f2 integer i integer i1 integer i2 integer iday integer ierror integer jday character ( len = 2 ) label(7) character ( len = 20 ) lines(6) integer m integer m2 integer month_length_common integer n_line character ( len = 9 ) s1 character ( len = 10 ) s2 integer w integer y integer y2 ! lines(1:6) = ' ' ! ! Make local copies of the input. ! m2 = m y2 = y ! ! Check the month and year. After this call, month is ! guaranteed to be between 1 and 12. ! call ym_check_common ( y2, m2, ierror ) if ( ierror /= 0 ) then return end if ! ! Find the day of the week for Y M 1. ! d2 = 1 f2 = 0.0D+00 call ymdf_to_weekday_common ( y2, m2, d2, f2, w ) days = month_length_common ( y2, m2 ) ! ! Find the appropriate label for the first box in the calendar. ! iday = 2 - w ! ! Print out a line of day numbers. ! IDAY keeps track of the numerical day, ! JDAY keeps track of the label for the day, which differed in October 1582. ! d2 = iday f2 = 0.0D+00 n_line = 0 do while ( iday <= days ) n_line = n_line + 1 do w = 1, 7 i1 = 3 * ( w - 1 ) + 1 i2 = i1 + 1 if ( 1 <= iday .and. iday <= days ) then write ( lines(n_line)(i1:i2), '(i2)' ) d2 end if iday = iday + 1 call ymdf_next_common ( y2, m2, d2, f2, y2, m2, d2, f2 ) end do end do return end subroutine month_carry_alexandrian ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_ALEXANDRIAN carries a year of months on the Alexandrian calendar. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! implicit none ! integer m integer months integer y integer year_length_months_alexandrian ! months = year_length_months_alexandrian( y ) do if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_common ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_COMMON carries a year of months on the Common calendar. ! ! ! Algorithm: ! ! While M > 12: ! ! decrease M by 12; ! increase Y by 1; ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_common ! do months = year_length_months_common ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_eg_civil ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_EG_CIVIL carries a year of months on the Egyptian Civil calendar. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! implicit none ! integer m integer months integer y integer year_length_months_eg_civil ! months = year_length_months_eg_civil ( y ) do if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_english ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_ENGLISH carries a year of months on the English calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_english ! do months = year_length_months_english ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_gregorian ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_GREGORIAN carries a year of months on the Gregorian calendar. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_gregorian ! do months = year_length_months_gregorian ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_hebrew ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_HEBREW carries a year of months on the Hebrew calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_hebrew ! do months = year_length_months_hebrew ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_islamic ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_ISLAMIC carries a year of months on the Islamic calendar. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_islamic ! do months = year_length_months_islamic ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_julian ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_JULIAN carries a year of months on the Julian calendar. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_julian ! do months = year_length_months_julian ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_republican ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_REPUBLICAN carries a year of months on the Republican calendar. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_republican ! do months = year_length_months_republican ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end subroutine month_carry_roman ( y, m ) ! !******************************************************************************* ! !! MONTH_CARRY_ROMAN carries a year of months on the Roman calendar. ! ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the year and month. ! On output, M is no greater than 12. ! implicit none ! integer m integer months integer y integer year_length_months_roman ! do months = year_length_months_roman ( y ) if ( m <= months ) then exit end if m = m - months y = y + 1 end do return end function month_length_alexandrian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ALEXANDRIAN returns the number of days in an Alexandrian month. ! ! ! Modified: ! ! 13 November 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 MONTH_LENGTH_ALEXANDRIAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(13) :: mdays = (/ & 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 5 /) integer month_length_alexandrian integer y integer y2 logical year_is_leap_alexandrian ! ! Copy the input. ! m2 = m y2 = y if ( m2 < 1 .or. m2 > 13 ) then month_length_alexandrian = 0 else month_length_alexandrian = mdays(m2) end if if ( m2 == 13 .and. year_is_leap_alexandrian ( y ) ) then month_length_alexandrian = month_length_alexandrian + 1 end if return end function month_length_bahai ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_BAHAI returns the number of days in a Bahai month. ! ! ! Modified: ! ! 22 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 MONTH_LENGTH_BAHAI, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer month_length_bahai integer y integer y2 logical year_is_leap_bahai ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_bahai ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_bahai = 0 return end if if ( m2 <= 18 .or. m2 == 20 ) then month_length_bahai = 19 else if ( year_is_leap_bahai ( y2 ) ) then month_length_bahai = 5 else month_length_bahai = 4 end if return end function month_length_common ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_COMMON returns the number of days in a Common month. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! The routine knows that February has 28 days, except in leap years, ! when it has 29. ! ! In the Common calendar, October 1582 had only 21 days ! ! Modified: ! ! 21 May 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 MONTH_LENGTH_COMMON, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) integer month_length_common integer y integer 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 month_length_common = 0 return end if ! ! Take care of the special case. ! if ( y2 == 1582 ) then if ( m2 == 10 ) then month_length_common = 21 return end if end if ! ! Get the number of days in the month. ! month_length_common = mdays ( m2 ) ! ! If necessary, add 1 day for February 29. ! if ( m2 == 2 .and. year_is_leap_common ( y2 ) ) then month_length_common = month_length_common + 1 end if return end function month_length_coptic ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_COPTIC returns the number of days in a Coptic 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 MONTH_LENGTH_COPTIC, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(13) :: mdays = (/ & 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 5 /) integer month_length_coptic integer y integer y2 logical year_is_leap_coptic ! ! Copy the input. ! m2 = m y2 = y if ( m2 < 1 .or. m2 > 13 ) then month_length_coptic = 0 else month_length_coptic = mdays(m2) end if if ( m2 == 13 .and. year_is_leap_coptic ( y2 ) ) then month_length_coptic = month_length_coptic + 1 end if return end function month_length_eg_civil ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_EG_CIVIL returns the number of days in an Egyptian Civil month. ! ! ! Modified: ! ! 15 November 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 MONTH_LENGTH_EG_CIVIL, the number of days in the month. ! implicit none ! integer m integer month_length_eg_civil integer y ! if ( m < 1 ) then month_length_eg_civil = 0 else if ( m <= 12 ) then month_length_eg_civil = 30 else if ( m == 13 ) then month_length_eg_civil = 5 else month_length_eg_civil = 0 end if return end function month_length_eg_lunar ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_EG_LUNAR returns the number of days in an Egyptian Lunar month. ! ! ! Modified: ! ! 15 November 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 MONTH_LENGTH_EG_LUNAR, the number of days in the month. ! implicit none ! integer ierror integer last integer m integer m2 integer, parameter, dimension(13) :: mdays = (/ & 29, 30, 29, 30, 29, 30, 29, 30, 29, 30, 29, 30, 30 /) integer month_length_eg_lunar integer y integer y2 logical year_is_leap_eg_lunar integer year_length_months_eg_lunar ! ! Copy the input. ! m2 = m y2 = y last = year_length_months_eg_lunar ( y2 ) if ( m2 < 1 ) then month_length_eg_lunar = 0 else if ( m2 <= last ) then month_length_eg_lunar = mdays(m2) else month_length_eg_lunar = 0 end if if ( m2 == last ) then if ( year_is_leap_eg_lunar ( y ) ) then month_length_eg_lunar = month_length_eg_lunar + 1 end if end if return end function month_length_english ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ENGLISH returns the number of days in an English month. ! ! ! Discussion: ! ! In the English calendar, September 1752 had only 19 days. ! ! Modified: ! ! 21 May 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 MONTH_LENGTH_ENGLISH, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) integer month_length_english integer y integer y2 logical year_is_leap_english ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_english ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_english = 0 return end if ! ! Take care of special cases: ! if ( y2 == 1752 ) then if ( m2 == 9 ) then month_length_english = 19 return end if end if ! ! Get the number of days in the month. ! month_length_english = mdays ( m2 ) ! ! If necessary, add 1 day for February 29. ! if ( m2 == 2 .and. year_is_leap_english ( y2 ) ) then month_length_english = month_length_english + 1 end if return end function month_length_ethiopian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ETHIOPIAN returns the number of days in an Ethiopian 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 MONTH_LENGTH_ETHIOPIAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(13) :: mdays = (/ & 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, 5 /) integer month_length_ethiopian integer y integer y2 logical year_is_leap_ethiopian ! ! Copy the input. ! m2 = m y2 = y if ( m2 < 1 .or. m2 > 13 ) then month_length_ethiopian = 0 else month_length_ethiopian = mdays(m2) end if if ( m2 == 13 .and. year_is_leap_ethiopian ( y2 ) ) then month_length_ethiopian = month_length_ethiopian + 1 end if return end function month_length_greek ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_GREEK returns the number of days in a Greek month. ! ! ! Modified: ! ! 15 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 MONTH_LENGTH_GREEK, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(13) :: mdays = (/ & 30, 29, 30, 29, 30, 29, 29, 30, 29, 30, 29, 30, 29 /) integer month_length_greek integer y integer y2 logical year_is_leap_greek logical year_is_embolismic_greek ! ! Copy the input. ! m2 = m y2 = y if ( m2 < 1 ) then month_length_greek = 0 return end if ! ! A 13-month year. ! if ( year_is_embolismic_greek ( y2 ) ) then if ( m2 > 13 ) then month_length_greek = 0 return end if month_length_greek = mdays(m2) if ( m2 == 7 .and. year_is_leap_greek ( y2 ) ) then month_length_greek = month_length_greek + 1 end if ! ! A 12 month year. ! else if ( m2 <= 6 ) then month_length_greek = mdays(m2) else if ( m2 <= 12 ) then month_length_greek = mdays(m2+1) else month_length_greek = 0 end if end if return end function month_length_gregorian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_GREGORIAN returns the number of days in a Gregorian month. ! ! ! Modified: ! ! 21 May 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 MONTH_LENGTH_GREGORIAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) integer month_length_gregorian integer y integer 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 month_length_gregorian = 0 return end if ! ! Get the number of days in the month. ! month_length_gregorian = mdays ( m2 ) ! ! If necessary, add 1 day for February 29. ! if ( m2 == 2 ) then if ( year_is_leap_gregorian ( y2 ) ) then month_length_gregorian = month_length_gregorian + 1 end if end if return end function month_length_hebrew ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_HEBREW returns the number of days in a Hebrew month. ! ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 333. ! ! Modified: ! ! 17 July 2000 ! ! Parameters: ! ! Input, integer Y, integer M, the year and month number. Note that ! some years only had 12 months in them, while others have 13. If ! Y only has 12 months, then the length of the 13th month is ! returned as 0 days. ! ! Output, integer MONTH_LENGTH_HEBREW, the number of days in the month. ! implicit none ! integer, dimension (6,13) :: a = reshape ( source = (/ & 30, 30, 30, 30, 30, 30, & 29, 29, 30, 29, 29, 30, & 29, 30, 30, 29, 30, 30, & 29, 29, 29, 29, 29, 29, & 30, 30, 30, 30, 30, 30, & 29, 29, 29, 30, 30, 30, & 30, 30, 30, 29, 29, 30, & 29, 29, 29, 30, 30, 29, & 30, 30, 30, 29, 29, 29, & 29, 29, 29, 30, 30, 30, & 30, 30, 30, 29, 29, 29, & 29, 29, 29, 30, 30, 30, & 0, 0, 0, 29, 29, 29 /), shape = (/ 6, 13 /) ) ! integer ierror integer m integer m2 integer month_length_hebrew integer type integer y integer y2 ! ! Copy the input ! y2 = y m2 = m ! ! Check the input. ! call ym_check_hebrew ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_hebrew = 0 return end if call year_to_type_hebrew ( y2, type ) if ( type < 1 .or. type > 6 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MONTH_LENGTH_HEBREW - Warning!' write ( *, '(a,i6)' ) ' Illegal year TYPE = ', type write ( *, '(a,i6)' ) ' Y = ', y2 month_length_hebrew = 0 else if ( m2 < 1 .or. m2 > 13 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MONTH_LENGTH_HEBREW - Warning!' write ( *, '(a,i6)' ) ' Illegal MONTH = ', m2 month_length_hebrew = 0 else month_length_hebrew = a(type,m2) end if return end function month_length_hindu_solar ( ) ! !******************************************************************************* ! !! MONTH_LENGTH_HINDU_SOLAR returns the number of days in a Hindu solar month. ! ! ! Discussion: ! ! Warning: this is a DOUBLE PRECISION quantity, with a fractional part! ! ! Modified: ! ! 03 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision MONTH_LENGTH_HINDU_SOLAR, the number of ! days in the month. ! implicit none ! double precision month_length_hindu_solar double precision year_length_hindu_solar ! month_length_hindu_solar = year_length_hindu_solar ( ) / 12.0D+00 return end function month_length_iranian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ISLAMIC returns the number of days in an Iranian month. ! ! ! Modified: ! ! 19 November 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 MONTH_LENGTH_IRANIAN, the number of days in the month. ! implicit none ! integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29 /) integer month_length_iranian integer y integer y2 logical year_is_leap_iranian ! ! Copy the input. ! m2 = m y2 = y ! ! Get the number of days in the month. ! month_length_iranian = mdays ( m2 ) ! ! If necessary, add 1 day for a leap year.. ! if ( m2 == 12 .and. year_is_leap_iranian ( y2 ) ) then month_length_iranian = month_length_iranian + 1 end if return end function month_length_islamic ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ISLAMIC returns the number of days in an Islamic month. ! ! ! Modified: ! ! 07 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 MONTH_LENGTH_ISLAMIC, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 30, 29, 30, 29, 30, 29, 30, 29, 30, 29, 30, 29 /) integer month_length_islamic integer y integer y2 logical year_is_leap_islamic ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_islamic ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_islamic = 0 return end if ! ! Get the number of days in the month. ! month_length_islamic = mdays ( m2 ) ! ! If necessary, add 1 day for a leap year. ! if ( m2 == 12 .and. year_is_leap_islamic ( y2 ) ) then month_length_islamic = month_length_islamic + 1 end if return end function month_length_julian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_JULIAN returns the number of days in a Julian month. ! ! ! Modified: ! ! 18 April 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 MONTH_LENGTH_JULIAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) integer month_length_julian integer y integer 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 month_length_julian = 0 return end if ! ! Get the number of days in the month. ! month_length_julian = mdays ( m2 ) ! ! If necessary, add 1 day for February 29. ! if ( m2 == 2 .and. year_is_leap_julian ( y2 ) ) then month_length_julian = month_length_julian + 1 end if return end function month_length_lunar ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_LUNAR returns the number of days in a lunar month. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year in which the month occurred. ! ! Input, integer M, the number of the month. ! ! Output, double precision MONTH_LENGTH_LUNAR, the number of days in ! the month. ! implicit none ! integer m double precision month_length_lunar integer y ! if ( m < 1 .or. m > 12 ) then month_length_lunar = 0 else month_length_lunar = 29.53058D+00 end if return end function month_length_persian ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_PERSIAN returns the number of days in a Persian month. ! ! ! Modified: ! ! 01 August 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 MONTH_LENGTH_PERSIAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29 /) integer month_length_persian integer y integer y2 logical year_is_leap_persian ! ! Copy the input. ! m2 = m y2 = y ! ! Get the number of days in the month. ! month_length_persian = mdays ( m2 ) ! ! If necessary, add 1 day for a leap year. ! if ( m2 == 12 .and. year_is_leap_persian ( y2 ) ) then month_length_persian = month_length_persian + 1 end if return end function month_length_republican ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_REPUBLICAN returns the number of days in a Republican month. ! ! ! Modified: ! ! 07 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 MONTH_LENGTH_REPUBLICAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer month_length_republican integer y integer y2 logical year_is_leap_republican ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_republican ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_republican = 0 return end if ! ! Get the number of days in the month. ! if ( 1 <= m2 .and. m2 <= 12 ) then month_length_republican = 30 else if ( m2 == 13 ) then if ( year_is_leap_republican ( y2 ) ) then month_length_republican = 6 else month_length_republican = 5 end if end if return end function month_length_roman ( y, m ) ! !******************************************************************************* ! !! MONTH_LENGTH_ROMAN returns the number of days in a Roman month. ! ! ! Modified: ! ! 15 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 MONTH_LENGTH_ROMAN, the number of days in the month. ! implicit none ! integer ierror integer m integer m2 integer, parameter, dimension(12) :: mdays = (/ & 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) integer month_length_roman integer y integer y2 logical year_is_leap_roman ! ! Copy the input. ! m2 = m y2 = y ! ! Check the input. ! call ym_check_roman ( y2, m2, ierror ) if ( ierror /= 0 ) then month_length_roman = 0 return end if month_length_roman = mdays(m2) if ( m2 == 2 .and. year_is_leap_roman ( y2 ) ) then month_length_roman = month_length_roman + 1 end if return end function month_length_synodic ( ) ! !******************************************************************************* ! !! MONTH_LENGTH_SYNODIC returns the mean synodic month length. ! ! ! Discussion: ! ! The synodic month is the time from one new moon to the next, that is, ! when the moon and Sun are in conjunction. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision MONTH_LENGTH_SYNODIC, the length of the ! mean synodic month, ! in days. ! implicit none ! double precision month_length_synodic ! month_length_synodic = 29.530588853 return end subroutine month_name_to_month_common ( month_name, m ) ! !******************************************************************************* ! !! MONTH_NAME_TO_MONTH_COMMON returns the month number of a Common month ! ! ! Discussion: ! ! Capitalization is ignored. The month name has to match up to ! the unique beginning of a month name, and the rest is ignored. ! Here are the limits: ! ! JAnuary ! February ! MARch ! APril ! MAY ! JUNe ! JULy ! AUgust ! September ! October ! November ! December ! ! Modified: ! ! 06 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) MONTH_NAME, a string containing a month ! name or abbreviation. ! ! Output, integer M, the number of the month, or -1 if the name ! could not be recognized. ! implicit none ! integer m character ( len = * ) month_name character ( len = 3 ) string ! string = month_name call s_cap ( string ) if ( string(1:2) == 'JA' ) then m = 1 else if ( string(1:1) == 'F' ) then m = 2 else if ( string(1:3) == 'MAR' ) then m = 3 else if ( string(1:2) == 'AP' ) then m = 4 else if ( string(1:3) == 'MAY' ) then m = 5 else if ( string(1:3) == 'JUN' ) then m = 6 else if ( string(1:3) == 'JUL' ) then m = 7 else if ( string(1:2) == 'AU' ) then m = 8 else if ( string(1:1) == 'S' ) then m = 9 else if ( string(1:1) == 'O' ) then m = 10 else if ( string(1:1) == 'N' ) then m = 11 else if ( string(1:1) == 'D' ) then m = 12 else m = - 1 end if return end subroutine month_to_ides_roman ( m, d ) ! !******************************************************************************* ! !! MONTH_TO_IDES_ROMAN returns the day of the ides of a Roman month. ! ! ! Modified: ! ! 14 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, integer D, the day of the ides of the month. ! implicit none ! integer d integer m integer, parameter, dimension(12) :: ides = (/ & 13, 13, 15, 13, 15, 13, 15, 13, 13, 15, 13, 13 /) ! if ( m < 1 .or. m > 12 ) then d = -1 else d = ides(m) end if return end subroutine month_to_month_name_bahai ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_BAHAI returns the name of a Bahai month. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer i integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(20) :: name = (/ & 'Baha ', 'Jalal ', 'Jamal ', 'Azamat ', & 'Nur ', 'Rahmat ', 'Kalimat ', 'Kamal ', & 'Asma ', 'Izzat ', 'Mashiyyat ', 'Ilm ', & 'Qudrat ', 'Qawl ', 'Masail ', 'Sharaf ', & 'Sultan ', 'Mulk ', 'Ayyam-i-Ha', 'Ala ' /) ! if ( m < 1 .or. m > 20 ) then do i = 1, len ( month_name ) month_name(i:i) = '?' end do else month_name = name(m) end if return end subroutine month_to_month_name_common ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_COMMON returns the name of a Common month. ! ! ! Modified: ! ! 12 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer i integer lens integer m character ( len = * ) month_name character ( len = 9 ), parameter, dimension(12) :: name = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) ! if ( m < 1 .or. m > 12 ) then do i = 1, len ( month_name ) month_name(i:i) = '?' end do else month_name = name(m) end if return end subroutine month_to_month_name_coptic ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_COPTIC returns the name of a Coptic month. ! ! ! Discussion: ! ! The names are closely related to the month names of the Egyptian ! Civil calendar. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(13) :: name = (/ & 'Tut ', 'Babah ', 'Hatur ', 'Kiyahk ', & 'Tubah ', 'Amshir ', 'Baramhat ', 'Baramundah', & 'Bashans ', 'Ba''unah ', 'Abib ', 'Misra ', & 'al-Nasi ' /) ! if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_eg_civil ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_EG_CIVIL returns the name of an Egyptian Civil month. ! ! ! Discussion: ! ! The 13th month had only 5 days, which were treated as the birthdays ! of Osiris, Horus, Set, Isis and Nephthys. ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(13) :: name = (/ & 'Thoth ', 'Phaophi ', 'Hathyr ', 'Choiak ', & 'Tybi ', 'Mecheir ', 'Phamenoth ', 'Pharmouthi', & 'Pachon ', 'Payni ', 'Epeiph ', 'Mesore ', & 'Epagomenai' /) ! if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_eg_lunar ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_EG_LUNAR returns the name of an Egyptian Lunar month. ! ! ! Discussion: ! ! "Akhet" means "flood", ! "Peret" means "going forth" (for planting), ! "Shomu" means "deficiency" (the dry season). ! ! Modified: ! ! 14 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(13) :: name = (/ & 'Akhet I ', 'Akhet II ', 'Akhet III ', 'Akhet IV ', & 'Peret I ', 'Peret II ', 'Peret III ', 'Peret IV ', & 'Shomu I ', 'Shomu II ', 'Shomu III ', 'Shomu IV ', & 'Shomu V ' /) ! if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_ethiopian ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_ETHIOPIAN returns the name of an Ethiopian month. ! ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(13) :: name = (/ & 'Maskaram ', 'Teqemt ', 'Khedar ', 'Takhsas ', & 'Ter ', 'Yakatit ', 'Magabit ', 'Miyazya ', & 'Genbot ', 'Sane ', 'Hamle ', 'Nahase ', & 'Paguemen ' /) ! if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_greek ( y, m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_GREEK returns the name of a Greek month. ! ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the year and month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 12 ), parameter, dimension(13) :: name = (/ & 'Hecatombaeon', 'Metageitnion', 'Boedromion ', 'Pyanepsion ', & 'Maemacterion', 'Poseidon ', 'Poseidon II ', 'Gamelion ', & 'Anthesterion', 'Elaphebolion', 'Munychion ', 'Thargelion ', & 'Scirophorion' /) integer y logical year_is_embolismic_greek ! ! 13 month year. ! if ( year_is_embolismic_greek ( y ) ) then if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if ! ! 12 month year. ! else if ( m < 1 .or. m > 12 ) then month_name = '?????' else if ( m <= 6 ) then month_name = name(m) else month_name = name(m+1) end if end if return end subroutine month_to_month_name_hebrew ( y, m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_HEBREW returns the name of a Hebrew month. ! ! ! Modified: ! ! 12 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, the year and month. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 9 ), parameter, dimension(13) :: name = (/ & 'Tishri ', 'Heshvan ', 'Kislev ', 'Tebet ', 'Shebat ', & 'Adar ', 'Veadar ', 'Nisan ', 'Iyar ', 'Sivan ', & 'Tammuz ', 'Ab ', 'Elul ' /) integer y logical year_is_embolismic_hebrew ! if ( year_is_embolismic_hebrew ( y ) ) then if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if else if ( m < 1 .or. m > 12 ) then month_name = '?????' else if ( m <= 6 ) then month_name = name(m) else month_name = name(m+1) end if end if return end subroutine month_to_month_name_hindu_lunar ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_HINDU_LUNAR returns the name of a Hindu lunar month. ! ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(12) :: name = (/ & 'Chaitra ', 'Vaisakha ', 'Jyaishtha ', 'Ashadha ', & 'Sravana ', 'Bhadrapada', 'Asvina ', 'Karttika ', & 'Margasira ', 'Pausha ', 'Magha ', 'Phalguna ' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_hindu_solar ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_HINDU_SOLAR returns the name of a Hindu solar month. ! ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(12) :: name = (/ & 'Mesha ', 'Vrshabha ', 'Mithuna ', 'Karka ', & 'Simha ', 'Kanya ', 'Tula ', 'Vrischika ', & 'Dhanus ', 'Makara ', 'Kumbha ', 'Mina ' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_iranian ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_IRANIAN returns the name of an Iranian month. ! ! ! Modified: ! ! 19 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 11 ), parameter, dimension(12) :: name = (/ & 'Farvardin ', 'Ordibehesht', 'Xordad ', 'Tir ', & 'Mordad ', 'Shahrivar ', 'Mehr ', 'Aban ', & 'Azar ', 'Dey ', 'Bahman ', 'Esfand ' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_islamic ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_ISLAMIC returns the name of an Islamic month. ! ! ! Modified: ! ! 14 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(12) :: name = (/ & 'Muharram ', 'Safar ', 'Rabi I ', 'Rabi II ', & 'Jumada I ', 'Jumada II ', 'Rajab ', 'Shaban ', & 'Ramadan ', 'Shawwal ', 'Dhul-quda ', 'Dhul-hejji' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_persian ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_PERSIAN returns the name of a Persian month. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 11 ), parameter, dimension(12) :: name = (/ & 'Farvardin ', 'Ordibehesht', 'Khordad ', 'Tir ', & 'Mordad ', 'Shahrivar ', 'Mehr ', 'Aban ', & 'Azar ', 'Dey ', 'Bahman ', 'Esfand ' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_republican ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_REPUBLICAN returns the name of a Republican month. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 14 ), parameter, dimension(13) :: name = (/ & 'Vendemaire ', 'Brumaire ', 'Frimaire ', 'Nivose ', & 'Pluviose ', 'Ventose ', 'Germinal ', 'Floreal ', & 'Prairial ', 'Messidor ', 'Thermidor ', 'Fructidor ', & 'Sansculottides' /) ! if ( m < 1 .or. m > 13 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_roman ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_ROMAN returns the name of a Roman month. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer i integer lens integer m character ( len = * ) month_name character ( len = 10 ), parameter, dimension(12) :: name = (/ & 'Januarius ', 'Februarius', 'Martius ', 'Aprilis ', & 'Maius ', 'Junius ', 'Julius ', 'Augustus ', & 'September ', 'October ', 'November ', 'December ' /) ! if ( m < 1 .or. m > 12 ) then do i = 1, len ( month_name ) month_name(i:i) = '?' end do else month_name = name(m) end if return end subroutine month_to_month_name_soor_san ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_SOOR_SAN returns the name of a Soor San month. ! ! ! Modified: ! ! 22 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 7 ), parameter, dimension(12) :: name = (/ & 'Baune ', 'Abib ', 'Meshri ', 'Tot ', & 'Babe ', 'Hatur ', 'Kyak ', 'Tabe ', & 'Mashir ', 'Buramat', 'Barsude', 'Bashans' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_month_name_zoroastrian ( m, month_name ) ! !******************************************************************************* ! !! MONTH_TO_MONTH_NAME_ZOROASTRIAN returns the name of a Zoroastrian month. ! ! ! Modified: ! ! 21 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, character ( len = * ) MONTH_NAME, the month name. ! implicit none ! integer m character ( len = * ) month_name character ( len = 11 ), parameter, dimension(12) :: name = (/ & 'Furvurdeen ', 'Ardibehest ', 'Khordad ', 'Tir ', & 'Amerdad ', 'Sherever ', 'Moher ', 'Aban ', & 'Adur ', 'Deh ', 'Bahman ', 'Aspendadmad' /) ! if ( m < 1 .or. m > 12 ) then month_name = '?????' else month_name = name(m) end if return end subroutine month_to_nones_roman ( m, d ) ! !******************************************************************************* ! !! MONTH_TO_NONES_ROMAN returns the day of the nones of a Roman month. ! ! ! Modified: ! ! 14 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the month index. ! ! Output, integer D, the day of the nones of the month. ! implicit none ! integer d integer m integer, parameter, dimension(12) :: nones = (/ & 5, 5, 7, 5, 7, 5, 7, 5, 5, 7, 5, 5 /) ! if ( m < 1 .or. m > 12 ) then d = -1 else d = nones(m) end if return end subroutine moon_phase_to_jed ( n, phase, jed ) ! !******************************************************************************* ! !! MOON_PHASE_TO_JED calculates the JED of a moon phase. ! ! ! Reference: ! ! Press, Flannery, Teukolsky, Vetterling, ! Numerical Recipes: The Art of Scientific Computing, ! Cambridge University Press. ! ! Modified: ! ! 06 June 2001 ! ! Parameters: ! ! Input, integer N, specifies that the N-th such phase of the moon since ! January 1900 is to be computed. ! ! Input, integer PHASE, specifies which phase is to be computed. ! 0=new moon, ! 1=first quarter, ! 2=full, ! 3=last quarter. ! ! Output, double precision JED, the Julian Ephemeris Date on which the ! requested phase occurs. ! implicit none ! double precision, parameter :: pi = 3.14159265358979323846264338327950288419716939937510D+00 double precision, parameter :: degrees_to_radians = pi / 180.0D+00 ! double precision am double precision as double precision c integer i integer j double precision jed integer n integer phase double precision t double precision xtra ! ! First estimate. ! j = 2415020 + 28 * n + 7 * phase ! ! Compute a correction term. ! c = n + phase / 4.0D+00 t = c / 1236.85D+00 xtra = 0.75933D+00 + 1.53058868D+00 * c & + ( 0.0001178D+00 - 0.000000155D+00 * t ) * t**2 as = degrees_to_radians * ( 359.2242D+00 + 29.105356D+00 * c ) am = degrees_to_radians * & ( 306.0253D+00 + 385.816918D+00 * c + 0.010730D+00 * t**2 ) if ( phase == 0 .or. phase == 2 ) then xtra = xtra + ( 0.1734D+00 - 0.000393D+00 * t ) * sin ( as ) & - 0.4068D+00 * sin ( am ) else if ( phase == 1 .or. phase == 3 ) then xtra = xtra + ( 0.1721D+00 - 0.0004D+00 * t ) * sin ( as ) & - 0.6280D+00 * sin ( am ) else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MOON_PHASE_TO_JED - Fatal error!' write ( *, '(a,i6)' ) ' Illegal PHASE option = ', phase return end if jed = dble ( j ) + xtra return end subroutine new_year_to_jed_hebrew ( y, jed ) ! !******************************************************************************* ! !! NEW_YEAR_TO_JED_HEBREW returns the JED of the beginning of a Hebrew year. ! ! ! Reference: ! ! E G Richards, ! Algorithm G, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 330. ! ! Modified: ! ! 12 April 2000 ! ! Parameters: ! ! Input, integer Y, the Hebrew year. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d integer e integer e_prime integer i_wrap double precision jed double precision jed_epoch integer mu integer t integer t_prime integer tc integer th integer w integer y ! ! Integer option. ! ! t = 31524 + 765433 * ( ( 235 * y - 234 ) / 19 ) ! d = t / 25920 ! t_prime = mod ( t, 25920 ) ! ! Real option. ! mu = ( 235 * y - 234 ) / 19 tc = 204 + 793 * mu th = 5 + 12 * mu + tc / 1080 d = 1 + 29 * mu + th / 24 t_prime = mod ( tc, 1080 ) + 1080 * mod ( th, 24 ) w = i_wrap ( d+1, 1, 7 ) e = mod ( 7 * y + 13, 19 ) / 12 e_prime = mod ( 7 * y + 6, 19 ) / 12 if ( t_prime >= 19940 .or. & ( t_prime >= 9924 .and. w == 3 .and. e == 0 ) .or. & ( t_prime >= 16788 .and. w == 2 .and. e == 0 .and. e_prime == 1 ) ) then d = d + 1 end if call epoch_to_jed_hebrew ( jed_epoch ) jed = jed_epoch - 1 + dble ( d + mod ( mod ( d + 5, 7 ), 2 ) ) return end subroutine now_to_jed ( jed ) ! !******************************************************************************* ! !! NOW_TO_JED expresses the current date as JED. ! ! ! Modified: ! ! 18 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d character ( len = 8 ) date double precision f integer h integer ierror double precision jed integer m integer mu integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mu = values(8) f = dble ( mu ) f = dble ( s ) + f / 1000.0D+00 f = dble ( n ) + f / 60.0D+00 f = dble ( h ) + f / 60.0D+00 f = f / 24.0D+00 call ymdf_to_jed_common ( y, m, d, f, jed ) return end subroutine now_to_yjf_common ( y, j, f ) ! !******************************************************************************* ! !! NOW_TO_YJF_COMMON expresses the current date as a Common YJF date. ! ! ! Modified: ! ! 18 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer Y, integer J, double precision F, the YJF date. ! implicit none ! character ( len = 8 ) date integer d1 double precision f double precision f1 integer h1 integer ierror integer j integer m1 integer mu1 integer n1 integer s1 character ( len = 10 ) time integer values(8) integer y integer y1 character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y1 = values(1) m1 = values(2) d1 = values(3) h1 = values(5) n1 = values(6) s1 = values(7) mu1 = values(8) f1 = dble ( mu1 ) f1 = dble ( s1 ) + f1 / 1000.0D+00 f1 = dble ( n1 ) + f1 / 60.0D+00 f1 = dble ( h1 ) + f1 / 60.0D+00 f1 = f1 / 24.0D+00 call ymdf_to_yjf_common ( y1, m1, d1, f1, y, j, f ) return end subroutine now_to_ymdf_common ( y, m, d, f ) ! !******************************************************************************* ! !! NOW_TO_YMDF_COMMON expresses the current date as a Common YMDF date. ! ! ! Modified: ! ! 18 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer Y, integer M, integer D, double precision F, the YMDF date. ! implicit none ! integer d character ( len = 8 ) date double precision f integer h integer m integer mu integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mu = values(8) f = dble ( mu ) f = dble ( s ) + f / 1000.0D+00 f = dble ( n ) + f / 60.0D+00 f = dble ( h ) + f / 60.0D+00 f = f / 24.0D+00 return end subroutine now_to_ymdhms_common ( y, m, d, h, n, s ) ! !******************************************************************************* ! !! NOW_TO_YMDHMS_COMMON expresses the current date as a Common YMDHMS date. ! ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer Y, integer M, integer D, H, N, S, the YMDHMS date. ! implicit none ! integer d character ( len = 8 ) date integer h integer m integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) return end subroutine r_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! R_RANDOM returns a random real in a given range. ! ! ! Discussion: ! ! Calls to the FORTRAN 90 random number generator should go through ! this routine, to guarantee that the random number seed has been set. ! ! Modified: ! ! 05 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RLO, RHI, the minimum and maximum values. ! ! Output, real R, the randomly chosen value. ! implicit none ! real r real rhi real rlo integer, save :: seed = 0 logical, save :: seeded = .false. real t real uniform_01_sample ! ! Make sure the random number generator has been seeded. ! if ( .not. seeded ) then call random_initialize ( seed ) seeded = .true. end if ! ! Pick T, a random number in (0,1). ! ! call random_number ( harvest = t ) ! t = uniform_01_sample ( seed ) ! ! Set R in ( RLO, RHI ). ! r = ( 1.0D+00 - t ) * rlo + t * rhi return end subroutine r_swap ( x, y ) ! !******************************************************************************* ! !! R_SWAP switches two real values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none ! real x real y real z ! z = x x = y y = z return end subroutine r_to_s_left ( r, s ) ! !******************************************************************************* ! !! R_TO_S_LEFT writes a real into a left justified character string. ! ! ! Method: ! ! A 'G14.6' format is used with a WRITE statement. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real number to be written into the string. ! ! Output, character ( len = * ) S, the string into which ! the real number is to be written. If the string is less than 14 ! characters long, it will will be returned as a series of ! asterisks. ! implicit none ! integer i integer nchar real r character ( len = * ) s character ( len = 14 ) s2 ! nchar = len ( s ) if ( nchar < 14 ) then do i = 1, nchar s(i:i) = '*' end do else if ( r == 0.0D+00 ) then s(1:14) = ' 0.0 ' else write ( s2, '(g14.6)' ) r s(1:14) = s2 end if ! ! Shift the string left. ! s = adjustl ( s ) return end subroutine random_initialize ( seed ) ! !******************************************************************************* ! !! RANDOM_INITIALIZE initializes the FORTRAN 90 random number seed. ! ! ! Discussion: ! ! If you don't initialize the random number generator, its behavior ! is not specified. If you initialize it simply by: ! ! call random_seed ! ! its behavior is not specified. On the DEC ALPHA, if that's all you ! do, the same random number sequence is returned. In order to actually ! try to scramble up the random number generator a bit, this routine ! goes through the tedious process of getting the size of the random ! number seed, making up values based on the current time, and setting ! the random number seed. ! ! And this is the FORTRAN 90 people's idea of convenience? ! ! And I still get poorly randomized values, somehow, having to do ! with a bad seed, or something. I am about ready to go back to ! using my own damn routine! ! ! Modified: ! ! 06 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer SEED, a seed value. ! implicit none ! integer date_time(8) integer i integer seed integer, allocatable :: seed_vector(:) integer seed_size real t integer value ! ! Initialize the random number seed. ! call random_seed ! ! Determine the size of the random number seed. ! call random_seed ( size = seed_size ) ! ! Allocate a seed of the right size. ! allocate ( seed_vector(seed_size) ) ! ! Get the current date and time. ! call date_and_time ( values = date_time ) ! ! Construct a slightly random value. ! seed = 0 do i = 1, 8 seed = ieor ( seed, date_time(i) ) end do ! ! Make slightly random assignments to SEED_VECTOR. ! do i = 1, seed_size seed_vector(i) = ieor ( seed, i ) end do ! ! Set the random number seed value. ! call random_seed ( put = seed_vector(1:seed_size) ) ! ! Free up the seed space. ! deallocate ( seed_vector ) ! ! Because EVEN THIS DOESN'T SEEM TO PROPERLY MIX UP THE RANDOM ! NUMBERS, call the random number routine a bunch of times. ! do i = 1, 100 call random_number ( harvest = t ) end do ! ! I STILL GET LOUSY RESULTS. THE HELL WITH IT! ! return end subroutine s_cap ( s ) ! !******************************************************************************* ! !! S_CAP replaces any lowercase letters by uppercase ones in a string. ! ! ! Modified: ! ! 16 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! character c integer i integer nchar character ( len = * ) s ! nchar = len ( s ) do i = 1, nchar c = s(i:i) call ch_cap ( c ) s(i:i) = c end do return end subroutine s_cat ( s1, s2, s3 ) ! !******************************************************************************* ! !! S_CAT concatenates two strings to make a third string. ! ! ! Modified: ! ! 11 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the "prefix" string. ! ! Input, character ( len = * ) S2, the "postfix" string. ! ! Output, character ( len = * ) S3, the string made by ! concatenating S1 and S2, ignoring any trailing blanks. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 ! s3 = trim ( s1 ) // trim ( s2 ) return end subroutine s_cat1 ( s1, s2, s3 ) ! !******************************************************************************* ! !! S_CAT1 concatenates two strings, with a single blank separator. ! ! ! Examples: ! ! S1 S2 S ! ! 'cat' 'dog' 'cat dog' ! ! Modified: ! ! 11 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the "prefix" string. ! ! Input, character ( len = * ) S2, the "postfix" string. ! ! Output, character ( len = * ) S3, the string made by concatenating ! S1, a blank, and S2, ignoring any trailing blanks. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 ! s3 = trim ( s1 ) // ' ' // trim ( s2 ) return end function s_eqi ( s1, s2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_eqi character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( c1 /= c2 ) then return end if end do do i = lenc + 1, len1 if ( s1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( s2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end subroutine s_to_hms ( s, pat, h, n, second ) ! !******************************************************************************* ! !! S_TO_HMS converts a string into a H:M:S date. ! ! ! Discussion: ! ! The characters in PAT indicate where the data is stored. A particular ! letter, such as "H", indicates, an hour field, while the number of "H" ! characters indicates the width of the field. ! ! The codes are: ! ! 'H' or 'h' an hour field ! 'M' or 'm' a minute field ! 'S' or 's' a second field ! ! Examples: ! ! S PAT ! ------------ ------------ ! '230859' 'hhmmss' ! '10:30' 'hh:mm' ! ! Modified: ! ! 06 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string containing the data. ! ! Input, character ( len = * ) PAT, describes how the data is stored. ! PAT must be the same length as S. ! ! Output, integer H, N, SECOND, the hour, minute and second ! represented by the string. Any item not read from the string will ! have a value of -1. ! implicit none ! integer h integer ierror integer ihi integer ilo integer last integer length integer n character ( len = * ) pat character ( len = * ) s integer second ! h = 0 n = 0 second = 0 length = min ( len ( s ), len ( pat ) ) ihi = 0 do while ( ihi < length ) ilo = ihi + 1 ihi = ilo do while ( ihi + 1 <= length ) if ( pat(ihi+1:ihi+1) /= pat(ilo:ilo) ) then exit end if ihi = ihi + 1 end do if ( pat(ilo:ilo) == 'H' .or. pat(ilo:ilo) == 'h' ) then call s_to_i ( s(ilo:ihi), h, ierror, last ) else if ( pat(ilo:ilo) == 'M' .or. pat(ilo:ilo) == 'm' ) then call s_to_i ( s(ilo:ihi), n, ierror, last ) else if ( pat(ilo:ilo) == 'S' .or. pat(ilo:ilo) == 's' ) then call s_to_i ( s(ilo:ihi), second, ierror, last ) end if end do return end subroutine s_to_i ( s, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If STRING is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character of S used to make IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last character ( len = * ) s ! ierror = 0 istate = 0 isgn = 1 ival = 0 do i = 1, len_trim ( s ) c = s(i:i) ! ! Haven't read anything. ! if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read the sign, expecting digits. ! else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if ! ! Have read at least one digit, expecting more. ! else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else ival = isgn * ival last = i - 1 return end if end if end do ! ! If we read all the characters in the string, see if we're OK. ! if ( istate == 2 ) then ival = isgn * ival last = len_trim ( s ) else ierror = 1 last = 0 end if return end subroutine s_to_ymd_common ( s, pat, y, m, d ) ! !******************************************************************************* ! !! S_TO_YMD_COMMON converts a string into a Common YMD date. ! ! ! Discussion: ! ! The characters in PAT indicate where the day, month and year data ! is stored. A particular letter, such as "Y", indicates, a year ! field, while the number of "Y" characters indicates the width of ! the field. ! ! The codes are: ! ! 'Y' or 'y', a year field ! 'M' or 'm', a numeric month field ! 'N' or 'n', a literal month field ! 'D' or 'd', a day field ! ! Examples: ! ! S PAT ! ------------ ------------ ! '19991031' 'YYYYMMDD' ! '10-31-99' 'MM-DD-YY' ! '10-31-99' 'MM/DD/YY' ! 'Oct 31 1999' 'NNN DD YYYY' ! ! Modified: ! ! 06 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string containing the data. ! ! Input, character ( len = * ) PAT, describes how the data is stored. ! PAT must be the same length as S. ! ! Output, integer Y, integer M, integer D, the YMD date ! represented by the string. Any item not read from the string will ! have a value of -1. ! implicit none ! integer d integer ierror integer ihi integer ilo integer last integer length integer m character ( len = * ) pat character ( len = * ) s integer y ! d = 0 m = 0 y = 0 length = min ( len ( s ), len ( pat ) ) ihi = 0 do while ( ihi < length ) ilo = ihi + 1 ihi = ilo do while ( ihi + 1 <= length ) if ( pat(ihi+1:ihi+1) /= pat(ilo:ilo) ) then exit end if ihi = ihi + 1 end do if ( pat(ilo:ilo) == 'Y' .or. pat(ilo:ilo) == 'y' ) then call s_to_i ( s(ilo:ihi), y, ierror, last ) else if ( pat(ilo:ilo) == 'M' .or. pat(ilo:ilo) == 'm' ) then call s_to_i ( s(ilo:ihi), m, ierror, last ) else if ( pat(ilo:ilo) == 'N' .or. pat(ilo:ilo) == 'n' ) then call month_name_to_month_common ( s(ilo:ihi), m ) else if ( pat(ilo:ilo) == 'D' .or. pat(ilo:ilo) == 'd' ) then call s_to_i ( s(ilo:ihi), d, ierror, last ) end if end do return end subroutine s_to_ymdhms_common ( s, pat, y, m, d, h, n, second ) ! !******************************************************************************* ! !! S_TO_YMDHMS_COMMON converts a string into a Common YMD H:M:S date. ! ! ! Discussion: ! ! The characters in PAT indicate where the data is stored. A particular ! letter, such as "Y", indicates, a year field, while the number of "Y" ! characters indicates the width of the field. ! ! The codes are: ! ! 'Y' a year field ! 'M' a numeric month field ! 'N' a literal month field ! 'D' a day field ! 'h' an hour field ! 'm' a minute field ! 's' a second field ! ! Examples: ! ! S PAT ! ------------ ------------ ! '19991031230859' 'YYYYMMDDhhmmss' ! '10-31-99' 'MM-DD-YY' ! '10-31-99' 'MM/DD/YY' ! 'Oct 31 1999' 'NNN DD YYYY' ! '10:30' 'hh:mm' ! ! Modified: ! ! 06 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, a string containing the data. ! ! Input, character ( len = * ) PAT, describes how the data is stored. ! PAT must be the same length as S. ! ! Output, integer Y, integer M, integer D, HOUR, N, SECOND, the YMDHMS ! date represented by the string. Any item not ! read from the string will have a value of -1. ! implicit none ! integer d integer h integer ierror integer ihi integer ilo integer last integer length integer m integer n character ( len = * ) pat character ( len = * ) s integer second integer y ! y = 0 m = 0 d = 0 h = 0 n = 0 second = 0 length = min ( len ( s ), len ( pat ) ) ihi = 0 do while ( ihi < length ) ilo = ihi + 1 ihi = ilo do while ( ihi + 1 <= length ) if ( pat(ihi+1:ihi+1) /= pat(ilo:ilo) ) then exit end if ihi = ihi + 1 end do if ( pat(ilo:ilo) == 'Y' ) then call s_to_i ( s(ilo:ihi), y, ierror, last ) else if ( pat(ilo:ilo) == 'M' ) then call s_to_i ( s(ilo:ihi), m, ierror, last ) else if ( pat(ilo:ilo) == 'N' ) then call month_name_to_month_common ( s(ilo:ihi), m ) else if ( pat(ilo:ilo) == 'D' ) then call s_to_i ( s(ilo:ihi), d, ierror, last ) else if ( pat(ilo:ilo) == 'h' ) then call s_to_i ( s(ilo:ihi), h, ierror, last ) else if ( pat(ilo:ilo) == 'm' ) then call s_to_i ( s(ilo:ihi), n, ierror, last ) else if ( pat(ilo:ilo) == 's' ) then call s_to_i ( s(ilo:ihi), second, ierror, last ) end if end do return end subroutine second_borrow_common ( y, m, d, h, n, s ) ! !******************************************************************************* ! !! SECOND_BORROW_COMMON "borrows" a minute of seconds in a common date. ! ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, N, S, the YMDHMS date. ! implicit none ! integer d integer h integer m integer n integer s integer y ! do while ( s < 0 ) s = s + 60 n = n - 1 call minute_borrow_common ( y, m, d, h, n ) end do return end subroutine second_carry_common ( y, m, d, h, n, s ) ! !******************************************************************************* ! !! SECOND_CARRY_COMMON is given a Common YMDHMS date, and carries seconds to minutes. ! ! ! Algorithm: ! ! While S >= 60: ! ! decrease S by 60; ! increase N by 1; ! if necessary, adjust H, D, M and Y. ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, H, N, S, ! the year, month, day, hours, minutes, seconds, ! On output, S is between 0 and 59. ! implicit none ! integer d integer h integer m integer n integer s integer y ! do while ( s >= 60 ) s = s - 60 n = n + 1 call minute_carry_common ( y, m, d, h, n ) end do return end subroutine ss_to_jed_unix ( s, jed ) ! !******************************************************************************* ! !! SS_TO_JED_UNIX converts a UNIX SS date to a JED. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision S, the UNIX date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! double precision d double precision jed double precision jed_epoch double precision s ! call epoch_to_jed_unix ( jed_epoch) d = s / ( 24.0D+00 * 60.0D+00 * 60.0D+00 ) jed = jed_epoch + d return end subroutine timestamp ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine transition_to_jed_common ( jed ) ! !******************************************************************************* ! !! TRANSITION_TO_JED_COMMON returns the Common calendar transition as a JED. ! ! ! Discussion: ! ! In the Common calendar, the last moment of the Julian calendar was ! 11:59 pm, 4 October 1582 Julian/CE, ! 11:59 pm, 14 October 1582 Gregorian. ! The first minute of the Gregorian calendar ended at ! 12:01 am, 5 October 1582 Julian, ! 12:01 am, 15 October 1582 Gregorian/CE. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the date. ! implicit none ! double precision jed ! jed = 2299160.5D+00 return end subroutine transition_to_jed_english ( jed ) ! !******************************************************************************* ! !! TRANSITION_TO_JED_ENGLISH returns the English calendar transition as a JED. ! ! ! Discussion: ! ! In the English calendar, the last moment of the Julian calendar was ! 11:59 pm, 2 September 1752 Julian/English, ! 11:59 pm, 13 September 1752 Gregorian/CE. ! The first minute of the Gregorian calendar ended at ! 12:01 am, 3 September 1752 Julian, ! 12:01 am, 15 September 1752 Gregorian/CE/English. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the date. ! implicit none ! double precision jed ! jed = 2361221.5D+00 return end subroutine transition_to_jed_jed ( jed ) ! !******************************************************************************* ! !! TRANSITION_TO_JED_JED returns the JED calendar transition as a JED. ! ! ! Discussion: ! ! In Scaliger's design of the JED, three cycles with different periods ! began on JED = 0. These three cycles coincide once more on the ! transition day. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the date. ! implicit none ! double precision jed ! jed = 2913943.0D+00 return end subroutine transition_to_jed_mayan_long ( jed ) ! !******************************************************************************* ! !! TRANSITION_TO_JED_MAYAN_LONG returns the Mayan long count calendar transition as a JED. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision JED, the Julian Ephemeris Date of the date. ! implicit none ! double precision jed ! jed = 2456285.5D+00 return end function uniform_01_sample ( iseed ) ! !******************************************************************************* ! !! UNIFORM_01_SAMPLE is a portable random number generator. ! ! ! Formula: ! ! ISEED = ISEED * (7**5) mod (2**31 - 1) ! RANDOM = ISEED * / ( 2**31 - 1 ) ! ! Modified: ! ! 01 March 1999 ! ! Parameters: ! ! Input/output, integer ISEED, the integer "seed" used to generate ! the output random number, and updated in preparation for the ! next one. ISEED should not be zero. ! ! Output, real UNIFORM_01_SAMPLE, a random value between 0 and 1. ! ! ! IA = 7**5 ! IB = 2**15 ! IB16 = 2**16 ! IP = 2**31-1 ! implicit none ! integer, parameter :: ia = 16807 integer, parameter :: ib15 = 32768 integer, parameter :: ib16 = 65536 integer, parameter :: ip = 2147483647 integer iprhi integer iseed integer ixhi integer k integer leftlo integer loxa real uniform_01_sample ! ! Don't let ISEED be 0. ! if ( iseed == 0 ) then iseed = ip end if ! ! Get the 15 high order bits of ISEED. ! ixhi = iseed / ib16 ! ! Get the 16 low bits of ISEED and form the low product. ! loxa = ( iseed - ixhi * ib16 ) * ia ! ! Get the 15 high order bits of the low product. ! leftlo = loxa / ib16 ! ! Form the 31 highest bits of the full product. ! iprhi = ixhi * ia + leftlo ! ! Get overflow past the 31st bit of full product. ! k = iprhi / ib15 ! ! Assemble all the parts and presubtract IP. The parentheses are ! essential. ! iseed = ( ( ( loxa - leftlo * ib16 ) - ip ) + ( iprhi - k * ib15 ) * ib16 ) & + k ! ! Add IP back in if necessary. ! if ( iseed < 0 ) then iseed = iseed + ip end if ! ! Multiply by 1 / (2**31-1). ! uniform_01_sample = real ( iseed ) * 4.656612875E-10 return end subroutine weekday_check_common ( w ) ! !******************************************************************************* ! !! WEEKDAY_CHECK_COMMON makes sure the Common weekday number is between 1 and 7. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer W, the weekday index. ! implicit none ! integer i_wrap integer w ! w = i_wrap ( w, 1, 7 ) return end subroutine weekday_to_name_bahai ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_BAHAI returns the name of a Bahai weekday. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 8 ), parameter, dimension(7) :: name = (/ & 'Jalal ', 'Jamal ', 'Kamal ', 'Fidal ', & 'Idal ', 'Istijlal', 'Istiqlal' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_common ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_COMMON returns the name of a Common weekday. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 9 ), parameter, dimension(7) :: name = (/ & 'Sunday ', 'Monday ', 'Tuesday ', 'Wednesday', & 'Thursday ', 'Friday ', 'Saturday ' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_common2 ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_COMMON2 returns the abbreviated name of a Common weekday. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = 2 ) S, the abbreviated weekday name. ! implicit none ! character ( len = 2 ), parameter, dimension(7) :: name = (/ & 'Su', ' M', 'Tu', ' W', 'Th', ' F', 'Sa' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_german ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_GERMAN returns the name of a German weekday. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 10 ), parameter, dimension(7) :: name = (/ & 'Sonntag ', 'Montag ', 'Dienstag ', 'Mittwoch ', & 'Donnerstag', 'Freitag ', 'Samstag ' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_hebrew ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_HEBREW returns the name of a Hebrew weekday. ! ! ! Modified: ! ! 19 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 12 ), parameter, dimension(7) :: name = (/ & 'Yom rishon ', 'Yom sheni ', 'Yom shelishi', 'Yom revii ', & 'Yom hamishi ', 'Yom shishi ', 'Sabbath ' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_islamic ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_ISLAMIC returns the name of an Islamic weekday. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 13 ), parameter, dimension(7) :: name = (/ & 'Yom ilHadd ', 'Yom litneen ', 'Yom ittalat ', 'Yom larba ', & 'Yom ilkhamiis', 'Yom ilguma ', 'Yom issabt ' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine weekday_to_name_republican ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_REPUBLICAN returns the name of a Republican weekday. ! ! ! Modified: ! ! 14 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 9 ), parameter, dimension(10) :: name = (/ & 'Primedi ', 'Duodi ', 'Tridi ', 'Quartidi', 'Quintidi', & 'Sextidi ', 'Septidi ', 'Octidi ', 'Nonidi ', 'Decadi ' /) character ( len = * ) s integer w ! if ( w < 1 .or. w > 10 ) then s = '?????' else s = name ( w ) end if return end subroutine weekday_to_name_roman ( w, s ) ! !******************************************************************************* ! !! WEEKDAY_TO_NAME_ROMAN returns the name of a Roman weekday. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer W, the weekday index. ! ! Output, character ( len = * ) S, the weekday name. ! implicit none ! character ( len = 13 ), parameter, dimension(7) :: name = (/ & 'Dies Solis ', 'Dies Lunae ', 'Dies Martis ', 'Dies Mercurii', & 'Dies Iovis ', 'Dies Veneris ', 'Dies Saturni ' /) character ( len = * ) s integer w integer w2 ! ! Make a local copy of the weekday number. ! w2 = w ! ! Check the weekday number. ! call weekday_check_common ( w2 ) ! ! Return the weekday name. ! s = name ( w2 ) return end subroutine y_astronomical_to_common ( y, y2 ) ! !******************************************************************************* ! !! Y_ASTRONOMICAL_TO_COMMON converts an Astronomical year to a Common year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the astronomical year. ! ! Output, integer Y2, the Common year. ! implicit none ! integer y integer y2 ! if ( y <= 0 ) then y2 = y - 1 else y2 = y end if return end subroutine y_check_alexandrian ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_ALEXANDRIAN checks an Alexandrian year. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_bahai ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_BAHAI checks a Bahai year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y <= 0 ) then ierror = 1 else ierror = 0 end if return end subroutine y_check_common ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_COMMON checks a Common year. ! ! ! Modified: ! ! 17 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y /= 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_eg_civil ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_EG_CIVIL checks an Egyptian Civil year. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_english ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_ENGLISH checks an English year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y /= 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_greek ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_GREEK checks a Greek year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y <= 0 ) then ierror = 1 else ierror = 0 end if return end subroutine y_check_gregorian ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_GREGORIAN checks a Gregorian year. ! ! ! Modified: ! ! 17 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y /= 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_hebrew ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_HEBREW checks a Hebrew year. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_islamic ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_ISLAMIC checks an Islamic year. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_julian ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_JULIAN checks a Julian year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must not be 0. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y /= 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_republican ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_REPUBLICAN checks a Republican year. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_check_roman ( y, ierror ) ! !******************************************************************************* ! !! Y_CHECK_ROMAN checks a Roman year. ! ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year, which must be positive. ! ! Output, integer IERROR, is 0 if Y is legal, and 1 otherwise. ! implicit none ! integer ierror integer y if ( y > 0 ) then ierror = 0 else ierror = 1 end if return end subroutine y_common_to_astronomical ( y, y2 ) ! !******************************************************************************* ! !! Y_COMMON_TO_ASTRONOMICAL converts a Common year to an Astronomical year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the Common year. ! ! Output, integer Y2, the Astronomical year. ! implicit none ! integer y integer y2 ! if ( y < 0 ) then y2 = y + 1 else if ( y == 0 ) then y2 = - huge ( 1 ) else y2 = y end if return end subroutine y_julian_to_roman ( y, y2 ) ! !******************************************************************************* ! !! Y_JULIAN_TO_ROMAN converts a Julian year to a Roman year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the Julian year. ! ! Output, integer Y2, the corresponding Roman year. ! implicit none ! integer ierror integer y integer y2 ! call y_check_julian ( y, ierror ) if ( ierror /= 0 ) then y2 = -1 return end if if ( y < 0 ) then y = y + 1 end if y2 = y + 753 return end subroutine y_roman_to_julian ( y, y2 ) ! !******************************************************************************* ! !! Y_ROMAN_TO_JULIAN converts a Roman year to a Julian year. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the Roman year. ! ! Output, integer Y2, the corresponding Julian year. ! implicit none ! integer ierror integer y integer y2 ! y2 = y - 753 if ( y2 <= 0 ) then y2 = y2 - 1 end if return end subroutine y_to_s ( y, s ) ! !******************************************************************************* ! !! Y_TO_S writes a year into a string. ! ! ! Modified: ! ! 02 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call i_to_s_left ( y, s ) return end subroutine y_to_s_alexandrian ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_ALEXANDRIAN writes an Alexandrian year into a string. ! ! ! Format: ! ! AX YearNumber ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! character ( len = * ) s integer y ! s(1:3) = 'AX ' call i_to_s_left ( y, s(4:) ) return end subroutine y_to_s_bahai ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_BAHAI writes a Bahai year into a string. ! ! ! Format: ! ! Bahai YearNumber ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call y_check_bahai ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_BAHAI - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if s(1:6) = 'Bahai ' call i_to_s_left ( y, s(7:) ) return end subroutine y_to_s_common ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_COMMON writes a Common year into a string. ! ! ! Format: ! ! YearNumber BCE ! YearNumber CE ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call y_check_common ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_COMMON - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if if ( y < 0 ) then s(1:4) = 'BCE ' call i_to_s_left ( -y, s(5:) ) else if ( y > 0 ) then s(1:3) = 'CE ' call i_to_s_left ( y, s(4:) ) end if return end subroutine y_to_s_coptic ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_COPTIC writes a Coptic year into a string. ! ! ! Format: ! ! Coptic YearNumber ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! character ( len = * ) s integer y ! s(1:7) = 'Coptic ' call i_to_s_left ( y, s(8:) ) return end subroutine y_to_s_eg_civil ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_EG_CIVIL writes an Egyptian Civil year into a string. ! ! ! Format: ! ! EN YearNumber ! ! Discussion: ! ! "EN" stands for the Era of Nabonassar, a Babylonian king who ! acceded in 747 BC, used by the astronomer Ptolemy to assign ! an artificial starting year for the Egyptian calendar. ! ! Modified: ! ! 14 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! character ( len = * ) s integer y ! s(1:3) = 'EN ' call i_to_s_left ( y, s(4:) ) return end subroutine y_to_s_eg_lunar ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_EG_LUNAR writes an Egyptian Lunar year into a string. ! ! ! Format: ! ! EL YearNumber ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! character ( len = * ) s integer y ! s(1:3) = 'EL ' call i_to_s_left ( y, s(4:) ) return end subroutine y_to_s_english ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_ENGLISH writes an English year into a string. ! ! ! Format: ! ! YearNumber BC ! YearNumber AD ! ! Modified: ! ! 19 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call y_check_english ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_ENGLISH - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if if ( y < 0 ) then s(1:3) = 'BC ' call i_to_s_left ( -y, s(4:) ) else if ( y > 0 ) then s(1:3) = 'AD' call i_to_s_left ( y, s(4:) ) end if return end subroutine y_to_s_ethiopian ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_ETHIOPIAN writes an Ethiopian year into a string. ! ! ! Format: ! ! Ethiopian YearNumber ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! character ( len = * ) s integer y ! s(1:10) = 'Ethiopian ' call i_to_s_left ( y, s(11:) ) return end subroutine y_to_s_greek ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_GREEK writes a Greek year into a string. ! ! ! Format: ! ! OL 87.1 ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer i_wrap integer ierror integer o character ( len = * ) s character ( len = 5 ) so character ( len = 1 ) syy integer y integer yy ! call y_check_greek ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_GREEK - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if o = 1 + ( ( y - 1 ) / 4 ) yy = i_wrap ( y, 1, 4 ) call i_to_s_left ( o, so ) call i_to_s_left ( yy, syy ) s = 'OL ' // trim ( so ) // '.' // trim ( syy ) return end subroutine y_to_s_gregorian ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_GREGORIAN writes a Gregorian year into a string. ! ! ! Format: ! ! YearNumber BC ! YearNumber AD ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call y_check_gregorian ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_GREGORIAN - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if if ( y < 0 ) then s(1:3) = 'BC ' call i_to_s_left ( -y, s(4:) ) else if ( y > 0 ) then s(1:3) = 'AD' call i_to_s_left ( y, s(4:) ) end if return end subroutine y_to_s_hebrew ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_HEBREW writes a Hebrew year into a string. ! ! ! Format: ! ! YearNumber AM ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = 10 ) sy character ( len = * ) s integer y ! call y_check_hebrew ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_HEBREW - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if call i_to_s_left ( y, sy ) call s_cat1 ( sy, 'AM', s ) return end subroutine y_to_s_islamic ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_ISLAMIC writes an Islamic year into a string. ! ! ! Format: ! ! YearNumber AH ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = 10 ) sy character ( len = * ) s integer y ! call y_check_islamic ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_ISLAMIC - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if call i_to_s_left ( y, sy ) call s_cat1 ( sy, 'AH', s ) return end subroutine y_to_s_julian ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_JULIAN writes a Julian year into a string. ! ! ! Format: ! ! YearNumber BC ! YearNumber AD ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! call y_check_julian ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_JULIAN - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if if ( y < 0 ) then s(1:3) = 'BC ' call i_to_s_left ( -y, s(4:) ) else if ( y > 0 ) then s(1:3) = 'AD' call i_to_s_left ( y, s(4:) ) end if return end subroutine y_to_s_persian ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_PERSIAN writes a Persian year into a string. ! ! ! Format: ! ! AP YearNumber ! ! Discussion: ! ! "AP" stands for "anno Persico". ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = * ) s integer y ! s(1:3) = 'AP ' call i_to_s_left ( y, s(4:) ) return end subroutine y_to_s_republican ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_REPUBLICAN writes a Republican year into a string. ! ! ! Format: ! ! YearNumber ER ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = 10 ) sy character ( len = * ) s integer y ! call y_check_republican ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_REPUBLICAN - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if call i_to_s_left ( y, sy ) call s_cat1 ( sy, 'ER', s ) return end subroutine y_to_s_roman ( y, s ) ! !******************************************************************************* ! !! Y_TO_S_ROMAN writes a Roman year into a string. ! ! ! Format: ! ! YearNumber AUC ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, character ( len = * ) S, a representation of the year. ! implicit none ! integer ierror character ( len = 30 ) sy character ( len = * ) s integer y ! call y_check_roman ( y, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Y_TO_S_ROMAN - Fatal error!' write ( *, '(a)' ) ' Illegal year.' stop end if call i_to_roman ( y, sy ) call s_cat1 ( sy, 'AUC', s ) return end subroutine year_cal_common ( y ) ! !******************************************************************************* ! !! YEAR_CAL_COMMON prints out a calendar for a Common year. ! ! ! Modified: ! ! 20 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! implicit none ! integer d integer i integer i1 integer i2 integer i3 integer iday integer ierror integer jday character ( len = 2 ) label(7) character ( len = 20 ) lines1(6) character ( len = 20 ) lines2(6) character ( len = 20 ) lines3(6) integer m1 integer m2 integer m3 integer month_length_common character ( len = 10 ) s1 character ( len = 10 ) s2 character ( len = 10 ) s3 character ( len = 10 ) s4 integer w integer w1 integer w2 integer w3 character ( len = 2 ) weekdays(7) integer y integer y2 ! ! Make local copies of the input. ! y2 = y ! ! Check the year. ! call y_check_common ( y2, ierror ) if ( ierror /= 0 ) then return end if ! ! Make the year heading. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COMMON CALENDAR' call y_to_s_common ( y2, s4 ) write ( *, '(6x,a)' ) trim ( s4 ) ! ! Print out the month headings. ! do m1 = 1, 12, 3 m2 = m1 + 1 m3 = m2 + 1 call month_to_month_name_common ( m1, s1 ) call month_to_month_name_common ( m2, s2 ) call month_to_month_name_common ( m3, s3 ) write ( *, '(a)' ) ' ' write ( *, '(5x,a,5x,2x,5x,a,5x,2x,5x,a)' ) s1, s2, s3 write ( *, '(a)' ) ' ' ! ! Get the days of the week. ! do w = 1, 7 call weekday_to_name_common2 ( w, weekdays(w) ) end do write ( *, '(7(a2,1x),1x,7(a2,1x),1x,7(a2,1x))' ) & weekdays(1:7), weekdays(1:7), weekdays(1:7) write ( *, '(a)' ) ' ' call month_cal_store_common ( y, m1, lines1 ) call month_cal_store_common ( y, m2, lines2 ) call month_cal_store_common ( y, m3, lines3 ) do i = 1, 6 write ( *, '(a,2x,a,2x,a)' ) lines1(i), lines2(i), lines3(i) end do end do return end function year_is_embolismic_eg_lunar ( y ) ! !******************************************************************************* ! !! YEAR_IS_EMBOLISMIC_EG_LUNAR returns TRUE if the Egyptian Lunar year was embolismic. ! ! ! Discussion: ! ! This is just a "fake" function, which does repeat every 25 years, ! and has 9 embolismic and 16 common years in that cycle, but with ! a pattern I just made up for now. ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_EMBOLISMIC_EG_LUNAR, TRUE if the year was embolismic. ! implicit none ! integer i_modp integer y integer y2 logical year_is_embolismic_eg_lunar ! y2 = mod ( y-1, 25 ) if ( mod ( y2, 3 ) == 0 ) then year_is_embolismic_eg_lunar = .true. else year_is_embolismic_eg_lunar = .false. end if return end function year_is_embolismic_greek ( y ) ! !******************************************************************************* ! !! YEAR_IS_EMBOLISMIC_GREEK returns TRUE if the Greek year was embolismic. ! ! ! Discussion: ! ! Apparently, the Greek calendar was emended haphazardly. This ! routine does not attempt to follow that historical pattern, and ! just uses the Hebrew calendar pattern for now. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_EMBOLISMIC_GREEK, TRUE if the year was embolismic. ! implicit none ! integer i_modp integer y logical year_is_embolismic_greek ! if ( i_modp ( 7 * y + 13, 19 ) >= 12 ) then year_is_embolismic_greek = .true. else year_is_embolismic_greek = .false. end if return end function year_is_embolismic_hebrew ( y ) ! !******************************************************************************* ! !! YEAR_IS_EMBOLISMIC_HEBREW returns TRUE if the Hebrew year was embolismic. ! ! ! Discussion: ! ! In a 19 year cycle, there are 7 embolismic years. During these years, ! an extra month, "Adar II", (sometimes called "Veadar") is inserted after ! the month of Adar. Nonembolismic years are called "common" years. ! ! Modified: ! ! 14 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_EMBOLISMIC_HEBREW, TRUE if the year was embolismic. ! implicit none ! integer i_modp integer y logical year_is_embolismic_hebrew ! if ( i_modp ( 7 * y + 13, 19 ) >= 12 ) then year_is_embolismic_hebrew = .true. else year_is_embolismic_hebrew = .false. end if return end function year_is_leap_alexandrian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_ALEXANDRIAN returns TRUE if the Alexandrian year was a leap year. ! ! ! Discussion: ! ! The Alexandrian year, which started on the 29th of August of the Julian ! year, was a leap year if it included the bissextile day of the Julian ! calendar. In other words, if the Alexandrian year BEGAN in a Julian year ! that preceded a Julian leap year, then the Alexandrian year was a leap year. ! ! We deem year AX 1 to have begun in Julian 23 BC. Julian 21 BC was ! theoretically a leap year, so AX 2 was a leap year, as was AX 6, AX 10, ! and so on. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_ALEXANDRIAN, TRUE if the year was a leap year. ! implicit none ! integer ierror integer y logical year_is_leap_alexandrian ! if ( mod ( y, 4 ) == 2 ) then year_is_leap_alexandrian = .true. else year_is_leap_alexandrian = .false. end if return end function year_is_leap_bahai ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_BAHAI returns TRUE if the Bahai year was a leap year. ! ! ! Discussion: ! ! The leap year rules are the same as those used in the Gregorian ! calendar. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_BAHAI, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y logical year_is_leap_bahai ! if ( y <= 0 ) then year_is_leap_bahai = .false. return end if if ( mod ( y, 400 ) == 0 ) then year_is_leap_bahai = .true. else if ( mod ( y, 100 ) == 0 ) then year_is_leap_bahai = .false. else if ( mod ( y, 4 ) == 0 ) then year_is_leap_bahai = .true. else year_is_leap_bahai = .false. end if return end function year_is_leap_common ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_COMMON returns TRUE if the Common year was a leap year. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! Algorithm: ! ! If ( the year is less than 0 ) then ! ! if the year+1 is divisible by 4 then ! the year is a leap year. ! ! else if ( the year is 0 ) then ! ! the year is not a leap year ( in fact, it's illegal ) ! ! else if ( the year is no greater than 1582 ) then ! ! if the year is divisible by 4 then ! the year is a leap year. ! ! else if ( ! the year is divisible by 4 and ! ( the year is not divisible by 100 ! or ! the year is divisible by 400 ) ! ) then ! the year is a leap year. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_COMMON, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer i_modp integer y integer y2 logical year_is_leap_common ! if ( y == 0 ) then year_is_leap_common = .false. return end if ! ! BC years have to have 1 added to them to make a proper leap year evaluation. ! call y_common_to_astronomical ( y, y2 ) if ( y2 <= 1582 ) then if ( i_modp ( y2, 4 ) == 0 ) then year_is_leap_common = .true. else year_is_leap_common = .false. end if else if ( i_modp ( y2, 400 ) == 0 ) then year_is_leap_common = .true. else if ( i_modp ( y2, 100 ) == 0 ) then year_is_leap_common = .false. else if ( i_modp ( y2, 4 ) == 0 ) then year_is_leap_common = .true. else year_is_leap_common = .false. end if end if return end function year_is_leap_coptic ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_COPTIC returns TRUE if the Coptic year was a leap year. ! ! ! Reference: ! ! Nachum Dershowitz and Edward Reingold, ! Calendrical Calculations, ! Cambridge, 1997, page 58. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_COPTIC, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y logical year_is_leap_coptic ! if ( y <= 0 ) then year_is_leap_coptic = .false. return end if if ( mod ( y, 4 ) == 3 ) then year_is_leap_coptic = .true. else year_is_leap_coptic = .false. end if return end function year_is_leap_eg_lunar ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_EG_LUNAR returns TRUE if the Egyptian Lunar year was a leap year. ! ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_EG_LUNAR, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y logical year_is_leap_eg_lunar ! if ( y <= 0 ) then year_is_leap_eg_lunar = .false. return end if if ( mod ( y, 5 ) == 0 ) then year_is_leap_eg_lunar = .true. else year_is_leap_eg_lunar = .false. end if return end function year_is_leap_english ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_ENGLISH returns TRUE if the English year was a leap year. ! ! ! Algorithm: ! ! If ( the year is less than 0 ) then ! ! if the year+1 is divisible by 4 then ! the year is a leap year. ! ! else if ( the year is 0 ) then ! ! the year is not a leap year ( in fact, it's illegal ) ! ! else if ( the year is no greater than 1752 ) then ! ! if the year is divisible by 4 then ! the year is a leap year. ! ! else if ( ! the year is divisible by 4 and ! ( the year is not divisible by 100 ! or ! the year is divisible by 400 ) ! ) then ! the year is a leap year. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_ENGLISH, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer i_modp integer y integer y2 logical year_is_leap_english ! if ( y == 0 ) then year_is_leap_english = .false. return end if ! ! BC years have to have 1 added to them to make a proper leap year evaluation. ! call y_common_to_astronomical ( y, y2 ) if ( y2 <= 1752 ) then if ( i_modp ( y2, 4 ) == 0 ) then year_is_leap_english = .true. else year_is_leap_english = .false. end if else if ( i_modp ( y2, 400 ) == 0 ) then year_is_leap_english = .true. else if ( i_modp ( y2, 100 ) == 0 ) then year_is_leap_english = .false. else if ( i_modp ( y2, 4 ) == 0 ) then year_is_leap_english = .true. else year_is_leap_english = .false. end if end if return end function year_is_leap_ethiopian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_ETHIOPIAN returns TRUE if the Ethiopian year was a leap year. ! ! ! Reference: ! ! Nachum Dershowitz and Edward Reingold, ! Calendrical Calculations, ! Cambridge, 1997, page 58. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_ETHIOPIAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y logical year_is_leap_ethiopian ! if ( y <= 0 ) then year_is_leap_ethiopian = .false. return end if if ( mod ( y, 4 ) == 3 ) then year_is_leap_ethiopian = .true. else year_is_leap_ethiopian = .false. end if return end function year_is_leap_greek ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_GREEK returns TRUE if the Greek year was a leap year. ! ! ! Discussion: ! ! The actual practice of adding the extra day to the Greek calendar ! seems to have been unmethodical. Here, we simply make up a rule ! as a placeholder for now. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_GREEK, TRUE if the year was a leap year. ! implicit none ! integer y logical year_is_embolismic_greek logical year_is_leap_greek ! if ( year_is_embolismic_greek ( y ) .and. ( mod ( y, 3 ) == 0 ) ) then year_is_leap_greek = .true. else year_is_leap_greek = .false. end if return end function year_is_leap_gregorian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_GREGORIAN returns TRUE if the Gregorian year was a leap year. ! ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_GREGORIAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer i_modp integer y integer y2 logical year_is_leap_gregorian ! if ( y == 0 ) then year_is_leap_gregorian = .false. return end if ! ! BC years have to have 1 added to them to make a proper leap year evaluation. ! call y_common_to_astronomical ( y, y2 ) if ( mod ( y2, 400 ) == 0 ) then year_is_leap_gregorian = .true. else if ( mod ( y2, 100 ) == 0 ) then year_is_leap_gregorian = .false. else if ( mod ( y2, 4 ) == 0 ) then year_is_leap_gregorian = .true. else year_is_leap_gregorian = .false. end if return end function year_is_leap_iranian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_IRANIAN returns TRUE if the Iranian year was a leap year. ! ! ! Discussion: ! ! I don't know the rule for this, so I'm just setting it FALSE for now. ! ! Modified: ! ! 19 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_IRANIAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y logical year_is_leap_iranian ! year_is_leap_iranian = .false. return end function year_is_leap_islamic ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_ISLAMIC returns TRUE if the Islamic year was a leap year. ! ! ! Discussion: ! ! In a 30 year cycle, there are 11 leap years, years 2, 5, 7, 10, 13, ! 16, 18, 21, 24, 26 and 29. During these years, the 12th month has ! 30 days instead of 29. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_ISLAMIC, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer i_modp integer y logical year_is_leap_islamic ! if ( i_modp ( 11 * y + 14, 30 ) < 11 ) then year_is_leap_islamic = .true. else year_is_leap_islamic = .false. end if return end function year_is_leap_julian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_JULIAN returns TRUE if the Julian year was a leap year. ! ! ! Algorithm: ! ! If ( Y < 0 and Y+1 is divisible by 4 ) then ! the year is a leap year. ! else if ( Y == 0 ) then ! the year is illegal ! else if ( Y > 0 and Y is divisible by 4 ) then ! the year is a leap year. ! else ! the year is NOT a leap year. ! ! Modified: ! ! 14 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_JULIAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer i_modp integer y integer y2 logical year_is_leap_julian ! if ( y == 0 ) then year_is_leap_julian = .false. return end if call y_common_to_astronomical ( y, y2 ) if ( i_modp ( y2, 4 ) == 0 ) then year_is_leap_julian = .true. else year_is_leap_julian = .false. end if return end function year_is_leap_persian ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_PERSIAN returns TRUE if the Persian year was a leap year. ! ! ! Reference: ! ! Nachum Dershowitz and Edward Reingold, ! Calendrical Calculations, ! Cambridge, 1997, page 58. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_PERSIAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer y integer y2 integer y3 logical year_is_leap_persian ! if ( y <= 0 ) then y2 = y - 473 else y2 = y - 474 end if y3 = 474 + mod ( y2, 2820 ) if ( mod ( 682 * ( y3 + 38 ), 2816 ) < 682 ) then year_is_leap_persian = .true. else year_is_leap_persian = .false. end if return end function year_is_leap_republican ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_REPUBLICAN returns TRUE if the Republican year was a leap year. ! ! ! Discussion: ! ! The French Republican calendar was in use for 14 years. ! In that time, years 3, 7 and 11 were designated as leap years. ! The easiest way to harmonize the rules and history is to apply ! the leap year rules to Y+1. ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_REPUBLICAN, TRUE if the year was a leap year, ! FALSE otherwise. ! implicit none ! integer ierror integer y integer y2 logical year_is_leap_republican ! y2 = y call y_check_republican ( y2, ierror ) if ( ierror /= 0 ) then year_is_leap_republican = .false. return end if year_is_leap_republican = .false. if ( mod ( y2+1, 4 ) == 0 ) then year_is_leap_republican = .true. if ( mod ( y2+1, 100 ) == 0 ) then year_is_leap_republican = .false. if ( mod ( y2+1, 400 ) == 0 ) then year_is_leap_republican = .true. if ( mod ( y2+1, 4000 ) == 0 ) then year_is_leap_republican = .false. end if end if end if end if return end function year_is_leap_roman ( y ) ! !******************************************************************************* ! !! YEAR_IS_LEAP_ROMAN returns TRUE if the Roman year was a leap year. ! ! ! Discussion: ! ! For our unrealistic and idealized Roman calendar, we are going to ! take a year to have been a leap year if the corresponding year in ! the idealized Julian calendar was a leap year. ! ! Modified: ! ! 20 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, logical YEAR_IS_LEAP_ROMAN, TRUE if the year was a leap year. ! implicit none ! integer ierror integer y integer y2 logical year_is_leap_julian logical year_is_leap_roman ! call y_check_roman ( y, ierror ) if ( ierror /= 0 ) then year_is_leap_roman = .false. return end if call y_roman_to_julian ( y, y2 ) year_is_leap_roman = year_is_leap_julian ( y2 ) return end function year_length_alexandrian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_ALEXANDRIAN returns the number of days in an Alexandrian year. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ALEXANDRIAN, the number of days in the year. ! implicit none ! integer y logical year_is_leap_alexandrian integer year_length_alexandrian ! if ( year_is_leap_alexandrian ( y ) ) then year_length_alexandrian = 366 else year_length_alexandrian = 365 end if return end function year_length_bahai ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_BAHAI returns the number of days in a Bahai year. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_BAHAI, the number of days in the year. ! implicit none ! integer y logical year_is_leap_bahai integer year_length_bahai ! if ( year_is_leap_bahai ( y ) ) then year_length_bahai = 366 else year_length_bahai = 365 end if return end function year_length_common ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_COMMON returns the number of days in a Common year. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! If Y is 0, then the routine returns 0, reflecting the fact that ! there was officially no year 0. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_COMMON, the number of days in the year. ! implicit none ! integer y integer year_length_common logical year_is_leap_common ! if ( y == 0 ) then year_length_common = 0 else if ( y == 1582 ) then year_length_common = 355 else if ( year_is_leap_common ( y ) ) then year_length_common = 366 else year_length_common = 365 end if return end function year_length_coptic ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_COPTIC returns the number of days in a Coptic year. ! ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_COPTIC, the number of days in the year. ! implicit none ! integer y logical year_is_leap_coptic integer year_length_coptic ! if ( year_is_leap_coptic ( y ) ) then year_length_coptic = 366 else year_length_coptic = 365 end if return end function year_length_eg_civil ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_EG_CIVIL returns the number of days in an Egyptian Civil year. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_EG_CIVIL, the number of days in the year. ! implicit none ! integer y integer year_length_eg_civil ! year_length_eg_civil = 365 return end function year_length_eg_lunar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_EG_LUNAR returns the number of days in an Egyptian Lunar year. ! ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_EG_LUNAR, the number of days in the year. ! implicit none ! integer y logical year_is_embolismic_eg_lunar logical year_is_leap_eg_lunar integer year_length_eg_lunar ! if ( .not. year_is_embolismic_eg_lunar ( y ) ) then if ( .not. year_is_leap_eg_lunar ( y ) ) then year_length_eg_lunar = 354 else year_length_eg_lunar = 355 end if else if ( .not. year_is_leap_eg_lunar ( y ) ) then year_length_eg_lunar = 384 else year_length_eg_lunar = 385 end if end if return end function year_length_english ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_ENGLISH returns the number of days in an English year. ! ! ! Discussion: ! ! The "English" calendar is meant to be the calendar which is Julian before ! the transition date, and Gregorian afterwards. ! ! 1752 was a special year with only 355 days instead of 366. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ENGLISH, the number of days in the year. ! implicit none ! integer y integer year_length_english logical year_is_leap_english ! if ( y == 0 ) then year_length_english = 0 else if ( y == 1752 ) then year_length_english = 355 else if ( year_is_leap_english ( y ) ) then year_length_english = 366 else year_length_english = 365 end if return end function year_length_ethiopian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_ETHIOPIAN returns the number of days in an Ethiopian year. ! ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ETHIOPIAN, the number of days in the year. ! implicit none ! integer y logical year_is_leap_ethiopian integer year_length_ethiopian ! if ( year_is_leap_ethiopian ( y ) ) then year_length_ethiopian = 366 else year_length_ethiopian = 365 end if return end function year_length_greek ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_GREEK returns the number of days in a Greek year. ! ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_GREEK, the number of days in the year. ! implicit none ! integer y integer year_length_greek logical year_is_embolismic_greek logical year_is_leap_greek ! year_length_greek = 357 if ( year_is_embolismic_greek ( y ) ) then year_length_greek = year_length_greek + 29 if ( year_is_leap_greek ( y ) ) then year_length_greek = year_length_greek + 1 end if end if return end function year_length_gregorian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_GREGORIAN returns the number of days in a Gregorian year. ! ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_GREGORIAN, the number of days in the year. ! implicit none ! integer y integer year_length_gregorian logical year_is_leap_gregorian ! if ( y == 0 ) then year_length_gregorian = 0 else if ( year_is_leap_gregorian ( y ) ) then year_length_gregorian = 366 else year_length_gregorian = 365 end if return end function year_length_hebrew ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_HEBREW returns the number of days in a Hebrew year. ! ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_HEBREW, the number of days in the year. ! implicit none ! double precision jed double precision jed2 integer y integer y2 integer year_length_hebrew ! call new_year_to_jed_hebrew ( y, jed ) y2 = y + 1 call new_year_to_jed_hebrew ( y2, jed2 ) year_length_hebrew = nint ( jed2 - jed ) return end function year_length_hindu_solar ( ) ! !******************************************************************************* ! !! YEAR_LENGTH_HINDU_SOLAR returns the number of days in a Hindu solar year. ! ! ! Discussion: ! ! Warning: This is a DOUBLE PRECISION quantity. ! ! Modified: ! ! 03 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision YEAR_LENGTH_HINDU_SOLAR, the number of days ! in the year. ! implicit none ! double precision year_length_hindu_solar ! year_length_hindu_solar = dble ( 1577917828 ) / dble ( 4320000 ) return end function year_length_islamic ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_ISLAMIC returns the number of days in an Islamic year. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ISLAMIC, the number of days in the year. ! implicit none ! integer y integer year_length_islamic logical year_is_leap_islamic ! if ( year_is_leap_islamic ( y ) ) then year_length_islamic = 355 else year_length_islamic = 354 end if return end function year_length_julian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_JULIAN returns the number of days in a Julian year. ! ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_JULIAN, the number of days in the year. ! implicit none ! integer y integer year_length_julian logical year_is_leap_julian ! if ( y == 0 ) then year_length_julian = 0 else if ( year_is_leap_julian ( y ) ) then year_length_julian = 366 else year_length_julian = 365 end if return end function year_length_lunar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_LUNAR returns the number of days in a "lunar year". ! ! ! Discussion: ! ! The "lunar year" is taken to be the length of 12 mean lunations. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, double precision YEAR_LENGTH_LUNAR, the number of days ! in the year. ! implicit none ! integer y double precision year_length_lunar ! year_length_lunar = 354.3671E+00 return end function year_length_months_alexandrian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_ALEXANDRIAN returns the number of months in an Alexandrian year. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_ALEXANDRIAN, the number of months in the year. ! implicit none ! integer y integer year_length_months_alexandrian ! year_length_months_alexandrian = 13 return end function year_length_months_bahai ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_BAHAI returns the number of months in a Bahai year. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_BAHAI, the number of months in the year. ! implicit none ! integer y integer year_length_months_bahai ! year_length_months_bahai = 20 return end function year_length_months_common ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_COMMON returns the number of months in a Common year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_COMMON, the number of months in the year. ! implicit none ! integer y integer year_length_months_common ! year_length_months_common = 12 return end function year_length_months_coptic ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_COPTIC returns the number of months in a Coptic year. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_COPTIC, the number of months in the year. ! implicit none ! integer y integer year_length_months_coptic ! year_length_months_coptic = 13 return end function year_length_months_eg_civil ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_EG_CIVIL returns the number of months in an Egyptian Civil year. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_EG_CIVIL, the number of months in the year. ! implicit none ! integer y integer year_length_months_eg_civil ! year_length_months_eg_civil = 13 return end function year_length_months_eg_lunar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_EG_LUNAR returns the number of months in an Egyptian Lunar year. ! ! ! Modified: ! ! 15 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_EG_LUNAR, the number of months in the year. ! implicit none ! integer y logical year_is_embolismic_eg_lunar integer year_length_months_eg_lunar ! if ( year_is_embolismic_eg_lunar ( y ) ) then year_length_months_eg_lunar = 13 else year_length_months_eg_lunar = 12 end if return end function year_length_months_english ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_ENGLISH returns the number of months in an English year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_ENGLISH, the number of months in the year. ! implicit none ! integer y integer year_length_months_english ! year_length_months_english = 12 return end function year_length_months_ethiopian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_ETHIOPIAN returns the number of months in an Ethiopian year. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_ETHIOPIAN, the number of months in the year. ! implicit none ! integer y integer year_length_months_ethiopian ! year_length_months_ethiopian = 13 return end function year_length_months_greek ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_GREEK returns the number of months in a Greek year. ! ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_GREEK, the number of months in the year. ! implicit none ! integer y logical year_is_embolismic_greek integer year_length_months_greek ! if ( year_is_embolismic_greek ( y ) ) then year_length_months_greek = 13 else year_length_months_greek = 12 end if return end function year_length_months_gregorian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_GREGORIAN returns the number of months in a Gregorian year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_GREGORIAN, the number of months in the year. ! implicit none ! integer y integer year_length_months_gregorian ! year_length_months_gregorian = 12 return end function year_length_months_hebrew ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_HEBREW returns the number of months in a Hebrew year. ! ! ! Modified: ! ! 23 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_HEBREW, the number of months in the year. ! implicit none ! integer y logical year_is_embolismic_hebrew integer year_length_months_hebrew ! if ( year_is_embolismic_hebrew ( y ) ) then year_length_months_hebrew = 13 else year_length_months_hebrew = 12 end if return end function year_length_months_hindu_lunar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_HINDU_LUNAR returns the number of months in a Hindu lunar year. ! ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_HINDU_LUNAR, the number of months in the year. ! implicit none ! integer y integer year_length_months_hindu_lunar ! year_length_months_hindu_lunar = 12 return end function year_length_months_hindu_solar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_HINDU_SOLAR returns the number of months in a Hindu solar year. ! ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_HINDU_SOLAR, the number of months in the year. ! implicit none ! integer y integer year_length_months_hindu_solar ! year_length_months_hindu_solar = 12 return end function year_length_months_islamic ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_ISLAMIC returns the number of months in an Islamic year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_ISLAMIC, the number of months in the year. ! implicit none ! integer y integer year_length_months_islamic ! year_length_months_islamic = 12 return end function year_length_months_julian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_JULIAN returns the number of months in a Julian year. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_JULIAN, the number of months in the year. ! implicit none ! integer y integer year_length_months_julian ! year_length_months_julian = 12 return end function year_length_months_persian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_PERSIAN returns the number of months in a Persian year. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_PERSIAN, the number of months in the year. ! implicit none ! integer y integer year_length_months_persian ! year_length_months_persian = 12 return end function year_length_months_republican ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_REPUBLICAN returns the number of months in a Republican year. ! ! ! Discussion: ! ! The routine always returns the value 13. The 13-th month was not ! regarded as a month, but as a special 5 or 6 day period known as ! the "Sansculottides". For our purposes, it's the 13th month. ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_REPUBLICAN, the number of months in ! the year. ! integer type integer y integer year_length_months_republican ! year_length_months_republican = 13 return end function year_length_months_roman ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_MONTHS_ROMAN returns the number of months in a Roman year. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_MONTHS_ROMAN, the number of months in the year. ! implicit none ! integer type integer y integer year_length_months_roman ! year_length_months_roman = 12 return end function year_length_persian ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_PERSIAN returns the number of days in a Persian year. ! ! ! Modified: ! ! 01 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_PERSIAN, the number of days in the year. ! implicit none ! integer y integer year_length_persian logical year_is_leap_persian ! if ( year_is_leap_persian ( y ) ) then year_length_persian = 366 else year_length_persian = 365 end if return end function year_length_republican ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_REPUBLICAN returns the number of days in a Republican year. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ENGLISH, the number of days in the year. ! implicit none ! integer y integer year_length_republican logical year_is_leap_republican ! if ( year_is_leap_republican ( y ) ) then year_length_republican = 366 else year_length_republican = 365 end if return end function year_length_roman ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_ROMAN returns the number of days in a Roman year. ! ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, integer YEAR_LENGTH_ROMAN, the number of days in the year. ! implicit none ! integer y integer year_length_roman logical year_is_leap_roman ! if ( year_is_leap_roman ( y ) ) then year_length_roman = 366 else year_length_roman = 365 end if return end function year_length_solar ( y ) ! !******************************************************************************* ! !! YEAR_LENGTH_SOLAR returns the number of days in a "solar" year. ! ! ! Discussion: ! ! The "solar" year is taken to be the mean tropical year. ! The number of days in a mean tropical year has varied from ! 365.2424992 in 4000 BC to 365.2421897 in 2000 AD. ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year to be checked. ! ! Output, double precision YEAR_LENGTH_SOLAR, the number of days in the year. ! implicit none ! integer y integer y2 double precision year_length_solar ! if ( y < 1 ) then y2 = y + 1 else y2 = y end if if ( y2 < -4000 ) then year_length_solar = 365.2424992D+00 else if ( y2 <= 2000 ) then year_length_solar = & ( dble ( 2000 - y2 ) * 365.2424992D+00 & + dble ( y2 + 4000 ) * 365.2421897D+00 ) & / 6000.0D+00 else year_length_solar = 365.2421897 end if return end subroutine year_to_dominical_common ( y, n1, n2 ) ! !******************************************************************************* ! !! YEAR_TO_DOMINICAL_COMMON: dominical numbers, Common calendar. ! ! ! Discussion: ! ! The Julian calendar calculations are used through the year 1582, ! and the Gregorian thereafter. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer N1, N2, the dominical numbers for the year. ! If Y is a leap year, then N1 applies before March 1, and N2 after. ! If Y is not a leap year, then N1 applies throughout the year, ! and N2 is returned as N1. ! implicit none ! integer n1 integer n2 integer y ! if ( y <= 1582 ) then call year_to_dominical_julian ( y, n1, n2 ) else call year_to_dominical_gregorian ( y, n1, n2 ) end if return end subroutine year_to_dominical_gregorian ( y, n1, n2 ) ! !******************************************************************************* ! !! YEAR_TO_DOMINICAL_GREGORIAN: dominical numbers, Gregorian calendar. ! ! ! Discussion: ! ! The days of each year are numbered with "calendar letters", with ! January 1 having letter 'A', January 7 having letter 'G', and ! the cycle then repeating with January 8 having letter 'A'. ! ! This cycle is independent of the weekday cycle. If a year is ! not a leap year, then all Sundays have the same calendar letter. ! This is called the dominical letter of the year. If a year is ! a leap year, then all Sundays before March 1 have one calendar ! letter, and all Sundays after have another (namely, the calendar ! letter one position earlier in the cycle). ! ! Using the correspondence A = 1, B = 2, ..., we may speak of ! the dominical number of a year, or dominical numbers for a leap year. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer N1, N2, the dominical numbers for the year. ! If Y is a leap year, then N1 applies before March 1, and N2 after. ! If Y is not a leap year, then N1 applies throughout the year, ! and N2 is returned as N1. ! implicit none ! integer i_modp integer n1 integer n2 integer p1 integer p2 integer y logical year_is_leap_common integer y2 ! if ( y == 0 ) then n1 = 0 n2 = 0 return end if call y_common_to_astronomical ( y, y2 ) p1 = y2 + ( y2 / 4 ) - ( y2 / 100 ) + ( y2 / 400 ) - 1 n1 = 7 - i_modp ( p1, 7 ) if ( year_is_leap_common ( y2 ) ) then p2 = p1 n2 = n1 p1 = p1 - 1 n1 = 7 - i_modp ( p1, 7 ) else n2 = n1 end if return end subroutine year_to_dominical_julian ( y, n1, n2 ) ! !******************************************************************************* ! !! YEAR_TO_DOMINICAL_JULIAN: dominical numbers, Julian calendar. ! ! ! Discussion: ! ! The days of each year are numbered with "calendar letters", with ! January 1 having letter 'A', January 7 having letter 'G', and ! the cycle then repeating with January 8 having letter 'A'. ! ! This cycle is independent of the weekday cycle. If a year is ! not a leap year, then all Sundays have the same calendar letter. ! This is called the dominical letter of the year. If a year is ! a leap year, then all Sundays before March 1 have one calendar ! letter, and all Sundays after have another (namely, the calendar ! letter one position earlier in the cycle). ! ! Using the correspondence A = 1, B = 2, ..., we may speak of ! the dominical number of a year, or dominical numbers for a leap year. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, integer Y, the year. The year 0 is illegal input. ! ! Output, integer N1, N2, the dominical numbers for the year. ! If Y is a leap year, then N1 applies before March 1, and N2 after. ! If Y is not a leap year, then N1 applies throughout the year, ! and N2 is returned as N1. ! implicit none ! integer i_modp integer n1 integer n2 integer p1 integer p2 integer y logical year_is_leap_julian integer y2 ! if ( y == 0 ) then n1 = 0 n2 = 0 return end if call y_common_to_astronomical ( y, y2 ) p1 = y2 + ( y2 / 4 ) + 4 n1 = 7 - i_modp ( p1, 7 ) if ( year_is_leap_julian ( y2 ) ) then p2 = p1 n2 = n1 p1 = p1 - 1 n1 = 7 - i_modp ( p1, 7 ) else n2 = n1 end if return end subroutine year_to_epact_gregorian ( y, e ) ! !******************************************************************************* ! !! YEAR_TO_EPACT_GREGORIAN returns the epact of a Gregorian year. ! ! ! Discussion: ! ! The epact of a year is the age in days of the notional moon on ! the first day of the year. If the year begins with a new moon, ! the epact is zero. If the new moon occurred the day before, ! the epact is 1. There is a unique epact for every golden number. ! ! The Gregorian epact calculation is an adjustment to the Julian ! calculation that takes into account the shift of the calendar ! to restore the vernal equinox to March 21, and the adjustment to ! the average length of the year. ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. The year 0 is illegal input. ! ! Output, integer E, the epact, between 0 and 28. ! implicit none ! integer e integer g integer h integer q integer y integer y2 ! if ( y == 0 ) then e = -1 return end if call y_common_to_astronomical ( y, y2 ) call year_to_golden_number ( y, g ) h = ( y2 / 100 ) q = h - ( h / 4 ) e = mod ( 57 + 11 * g - q + ( h - ( h - 17 ) / 25 ) / 3, 30 ) if ( e == 24 .or. ( e == 25 .and. g >= 12 ) ) then e = e + 1 end if return end subroutine year_to_epact_julian ( y, e ) ! !******************************************************************************* ! !! YEAR_TO_EPACT_JULIAN returns the epact of a Julian year. ! ! ! Discussion: ! ! The epact of a year is the age in days of the notional moon on ! the first day of the year. If the year begins with a new moon, ! the epact is zero. If the new moon occurred the day before, ! the epact is 1. There is a unique epact for every golden number. ! ! Bear in mind that the notional moon is not the one in the sky, ! but a theoretical one that satisfactorily approximates the behavior ! of the real one, but which is tame enough to be described by a formula. ! ! Example: ! ! Year Golden Number Epact ! ! 1 BC 1 8 ! 1 AD 2 19 ! 2 AD 3 0 ! 3 AD 4 11 ! 4 AD 5 22 ! 5 AD 6 3 ! 6 AD 7 14 ! 7 AD 8 25 ! 8 AD 9 6 ! 9 AD 10 17 ! 10 AD 11 28 ! 11 AD 12 9 ! 12 AD 13 20 ! 13 AD 14 1 ! 14 AD 15 12 ! 15 AD 16 23 ! 16 AD 17 4 ! 17 AD 18 15 ! 18 AD 19 26 ! 19 AD 1 8 ! 20 AD 2 19 ! 1066 AD 3 0 ! 1900 AD 1 8 ! 1919 AD 1 8 ! 1938 AD 1 8 ! 1957 AD 1 8 ! 1976 AD 1 8 ! 1995 AD 1 8 ! 2014 AD 1 8 ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999. ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. The year 0 is illegal input. ! ! Output, integer E, the epact, between 0 and 28. ! implicit none ! integer e integer g integer i_wrap integer y ! if ( y == 0 ) then e = -1 return end if call year_to_golden_number ( y, g ) e = i_wrap ( 11 * g - 3, 0, 29 ) return end subroutine year_to_golden_number ( y, g ) ! !******************************************************************************* ! !! YEAR_TO_GOLDEN_NUMBER returns the golden number of a Common year. ! ! ! Discussion: ! ! Nineteen solar years are very close to 235 lunations. Calendars ! that try to keep track of both the sun and moon often make use of ! this fact, ascribed to the Greek astronomer Meton. ! ! While trying to determine a formula for Easter, Dionysus Exiguus ! symbolized the place of each year in its Metonic cycle by a ! "golden number" between 1 and 19. The numbering began with the ! year 1 BC, assigned the golden number of 1. The following year, ! 1 AD, got the golden number of 2, and after that it gets easier. ! ! The same golden year calculation is done for years in the Julian ! or Gregorian calendar. ! ! Example: ! ! Year Golden Number ! ! 1 BC 1 ! 1 AD 2 ! 2 AD 3 ! 18 AD 19 ! 19 AD 1 ! 20 AD 2 ! 1066 AD 3 ! 1900 AD 1 ! 1919 AD 1 ! 1938 AD 1 ! 1957 AD 1 ! 1976 AD 1 ! 1995 AD 1 ! 2014 AD 1 ! ! Modified: ! ! 16 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer G, the golden number, between 1 and 19. This ! records the position of the year in the 19 year Metonic cycle. ! implicit none ! integer g integer i_wrap integer y integer y2 ! if ( y == 0 ) then g = -1 return end if ! ! We assume that BC years come in as negative numbers, and that ! the year before 1 AD is 1 BC. So add 1 to any negative value ! so that the arithmetic works. ! call y_common_to_astronomical ( y, y2 ) g = i_wrap ( y2+1, 1, 19 ) return end subroutine year_to_indiction_common ( y, i ) ! !******************************************************************************* ! !! YEAR_TO_INDICTION_COMMON returns the indiction number of a Common year. ! ! ! Discussion: ! ! The Roman empire had a taxation cycle that, at one time, comprised ! 15 years. As is typical in calendrical matters, the actual length ! of this cycle and the time that the cycle began varied from place ! to place and time to time, and historians even disagree about the ! indiction cycle given a specific place and time. Nonetheless, ! it is customary to retrospectively impose a uniform and regular ! indiction cycle on the ancient world. (The 15 year indiction cycle, ! in fact, was factored into Scaliger's determination of an appropriate ! starting point for the Julian Ephemeris Date.) ! ! Example: ! ! Year Indiction Number ! ! 3 BC 1 ! 2 BC 2 ! 1 BC 3 ! 1 AD 4 ! 10 AD 13 ! 11 AD 14 ! 12 AD 15 ! 13 AD 1 ! 14 AD 2 ! 15 AD 3 ! 26 AD 14 ! 27 AD 15 ! 28 AD 1 ! 1900 AD 13 ! 2000 AD 8 ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the year. ! ! Output, integer I, the indiction number, between 1 and 15. ! implicit none ! integer i integer i_wrap integer y integer y2 ! if ( y == 0 ) then i = -1 return end if ! ! We assume that BC years come in as negative numbers, and that ! the year before 1 AD is 1 BC. So add 1 to any negative value ! so that the arithmetic works. ! call y_common_to_astronomical ( y, y2 ) i = i_wrap ( y2+3, 1, 15 ) return end subroutine year_to_scaliger_common ( y, c1, c2, c3, r1, r2, r3 ) ! !******************************************************************************* ! !! Y_TO_SCALIGER_COMMON converts a Common year to its Scaliger indices. ! ! ! Discussion: ! ! The year 4713 BCE was chosen by Joseph Scaliger for the start of ! his Julian Ephemeris Date system, because three cycles coincided ! in that year, the 28 year Julian calendar cycle, the 19 year Metonic ! cycle, and the 15 year Roman Indiction cycle. Thus, the year ! 4713 BCE has Scaliger index (1,1,1). Each subsequent year has a distinct ! set of Scaliger indices until 7980 years later, when the year ! 3266 CE will again have the Scaliger index (1,1,1). ! ! Modified: ! ! 18 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the Common year. ! ! Output, integer C1, integer C2, integer C3, the number of completed ! Julian, Metonic and Indiction cycles. ! ! Output, integer R1, integer R2, integer R3, the Julian, Metonic and ! Indiction cycle numbers that make up the Scaliger index. ! implicit none ! integer c1 integer c2 integer c3 integer i_wrap integer r1 integer r2 integer r3 integer y integer y2 ! r1 = 0 r2 = 0 r3 = 0 if ( y == 0 ) then return end if ! ! Adjust for missing year 0. ! if ( y < 0 ) then y2 = y + 1 else y2 = y end if ! ! Now shift so 4713 BC becomes the year 1. ! y2 = y2 + 4713 c1 = ( y2 - 1 ) / 28 c2 = ( y2 - 1 ) / 19 c3 = ( y2 - 1 ) / 15 r1 = i_wrap ( y2, 1, 28 ) r2 = i_wrap ( y2, 1, 19 ) r3 = i_wrap ( y2, 1, 15 ) return end subroutine year_to_type_hebrew ( y, type ) ! !******************************************************************************* ! !! YEAR_TO_TYPE_HEBREW returns the type of a Hebrew year. ! ! ! Reference: ! ! E G Richards, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 332. ! ! Modified: ! ! 09 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, the Hebrew year. Nonpositive years are illegal input. ! ! Output, integer TYPE, the year type. ! 1, Common, Deficient, 12 months, 353 days; ! 2, Common, Regular, 12 months, 354 days; ! 3, Common, Abundant, 12 months, 355 days; ! 4, Embolismic, Deficient, 13 months, 383 days; ! 5, Embolismic, Regular, 13 months, 384 days; ! 6, Embolismic, Abundant, 13 months, 385 days. ! implicit none ! double precision jed double precision jed2 integer type integer y integer year_length ! if ( y <= 0 ) then type = -1 return end if call new_year_to_jed_hebrew ( y, jed ) call new_year_to_jed_hebrew ( y+1, jed2 ) year_length = nint ( jed2 - jed ) if ( year_length == 353 ) then type = 1 else if ( year_length == 354 ) then type = 2 else if ( year_length == 355 ) then type = 3 else if ( year_length == 383 ) then type = 4 else if ( year_length == 384 ) then type = 5 else if ( year_length == 385 ) then type = 6 else type = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'YEAR_TO_TYPE_HEBREW - Fatal error!' write ( *, '(a,i6)' ) ' Computed an illegal type = ', type stop end if return end subroutine yj_check_common ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_COMMON checks a Common YJ date. ! ! ! Modified: ! ! 08 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_common ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_common ( y, j ) call j_carry_common ( y, j ) return end subroutine yj_check_english ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_ENGLISH checks an English YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_english ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_english ( y, j ) call j_carry_english ( y, j ) return end subroutine yj_check_gregorian ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_GREGORIAN checks a Gregorian YJ date. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_gregorian ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_gregorian ( y, j ) call j_carry_gregorian ( y, j ) return end subroutine yj_check_hebrew ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_HEBREW checks a Hebrew YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_hebrew ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_hebrew ( y, j ) call j_carry_hebrew ( y, j ) return end subroutine yj_check_islamic ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_ISLAMIC checks an Islamic YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_islamic ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_islamic ( y, j ) call j_carry_islamic ( y, j ) return end subroutine yj_check_julian ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_JULIAN checks a Julian YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_julian ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_julian ( y, j ) call j_carry_julian ( y, j ) return end subroutine yj_check_republican ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_REPUBLICAN checks a Republican YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_republican ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_republican ( y, j ) call j_carry_republican ( y, j ) return end subroutine yj_check_roman ( y, j, ierror ) ! !******************************************************************************* ! !! YJ_CHECK_ROMAN checks a Roman YJ date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, the YJ date. ! ! Output, integer IERROR, is 0 if no serious error was found in ! the date, and 1 otherwise. ! implicit none ! integer ierror integer j integer y ! ! Check the year. ! call y_check_roman ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure J is not too small or too big. ! call j_borrow_roman ( y, j ) call j_carry_roman ( y, j ) return end subroutine yj_to_s_common ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_COMMON writes a Common YJ date into a string. ! ! ! Format: ! ! CE YYYY/JJJ ! BCE YYYY/JJJ ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_common ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'CE ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BCE ' call i_to_s_left ( - y, s1(5:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_english ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_ENGLISH writes an English YJ date into a string. ! ! ! Format: ! ! AD YYYY/JJJ ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_english ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_gregorian ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_GREGORIAN writes a Gregorian YJ date into a string. ! ! ! Format: ! ! AD YYYY/JJJ ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_gregorian ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_hebrew ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_HEBREW writes a Hebrew YJ date into a string. ! ! ! Format: ! ! AM YYYY/JJJ ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_hebrew ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AM ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_islamic ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_ISLAMIC writes an Islamic YJ date into a string. ! ! ! Format: ! ! AH YYYY/JJJ ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_islamic ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AH ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_julian ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_JULIAN writes a Julian YJ date into a string. ! ! ! Format: ! ! AD YYYY/JJJ ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_julian ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_numeric ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_NUMERIC "prints" a YJ date into a string. ! ! ! Format: ! ! YYYY/JJJ ! ! Modified: ! ! 23 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_common ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_republican ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_REPUBLICAN writes a Republican YJ date into a string. ! ! ! Format: ! ! ER YYYY/JJJ ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_republican ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'ER ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yj_to_s_roman ( y, j, s ) ! !******************************************************************************* ! !! YJ_TO_S_ROMAN writes a Roman YJ date into a string. ! ! ! Format: ! ! AUC YYYY/JJJ ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJ date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_roman ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AUC ' call i_to_s_left ( y, s1(5:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) return end subroutine yjf_check_common ( y, j, f, ierror ) ! !******************************************************************************* ! !! YJF_CHECK_COMMON normalizes a Common YJF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer J, double precision F, the YJF date. ! ! Output, integer IERROR, nonzero if there was an error. ! implicit none ! double precision f integer ierror integer j integer y ! call yj_check_common ( y, j, ierror ) if ( ierror /= 0 ) then return end if ! ! Force the fraction to lie between 0 and 1. ! do while ( f < 0.0D+00 ) f = f + 1.0D+00 j = j - 1 end do do while ( f >= 1.0D+00 ) f = f - 1.0D+00 j = j + 1 end do return end subroutine yjf_compare ( y1, j1, f1, y2, j2, f2, cmp ) ! !******************************************************************************* ! !! YJF_COMPARE compares two YJF dates. ! ! ! Discussion: ! ! The routine is "generic" and does not assume a particular calendar. ! However, it does assume that the calendar dates are "normalized". ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the first YJF date. ! ! Input, integer Y2, integer J2, double precision F2, the second YJF date. ! ! Output, character CMP: ! '<' if date 1 precedes date 2; ! '=' if date 1 equals date 2; ! '>' if date 1 follows date 2; ! implicit none ! character cmp double precision f1 double precision f2 integer ierror integer j1 integer j2 integer y1 integer y2 ! if ( y1 < y2 ) then cmp = '<' else if ( y1 > y2 ) then cmp = '>' else if ( j1 < j2 ) then cmp = '<' else if ( j1 > j2 ) then cmp = '>' else if ( f1 < f2 ) then cmp = '<' else if ( f1 > f2 ) then cmp = '>' else cmp = '=' end if end if end if return end subroutine yjf_dif_common ( y1, j1, f1, y2, j2, f2, days, ierror ) ! !******************************************************************************* ! !! YJF_DIF_COMMON computes day difference between two Common YJF dates. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the first YJF date. ! ! Input, integer Y2, integer J2, double precision F2, the second YJF date. ! ! Output, double precision DAYS, the day difference between the two dates. ! ! Output, integer IERROR, is 1 if either date is illegal, ! 0 otherwise. ! implicit none ! double precision days double precision f1 double precision f2 integer ierror integer j1 integer j2 double precision jed1 double precision jed2 integer y1 integer y2 ! ! Check the dates. ! call yjf_check_common ( y1, j1, f1, ierror ) if ( ierror /= 0 ) then return end if call yjf_check_common ( y2, j2, f2, ierror ) if ( ierror /= 0 ) then return end if call yjf_to_jed_common ( y1, j1, f1, jed1 ) call yjf_to_jed_common ( y2, j2, f2, jed2 ) days = jed2 - jed1 return end subroutine yjf_random_common ( y1, j1, f1, y2, j2, f2, y, j, f ) ! !******************************************************************************* ! !! YJF_RANDOM_COMMON picks a random Common YJF date between two given dates. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the first YJF date. ! ! Input, integer Y2, integer J2, double precision F2, the second YJF date. ! ! Output, integer Y, integer J, double precision F, the random YJF date. ! implicit none ! integer f integer f1 integer f2 integer j integer j1 integer j2 double precision jed double precision jed1 double precision jed2 integer y integer y1 integer y2 ! call yjf_to_jed_common ( y1, j1, f1, jed1 ) call yjf_to_jed_common ( y2, j2, f2, jed2 ) call d_random ( jed1, jed2, jed ) call jed_to_yjf_common ( jed, y, j, f ) return end subroutine yjf_swap ( y1, j1, f1, y2, j2, f2 ) ! !******************************************************************************* ! !! YJF_SWAP swaps the data defining two YJF dates. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y1, integer J1, double precision F1, integer Y2, ! integer J2, double precision F2, the YJF dates to be swapped. ! implicit none ! double precision f1 double precision f2 integer j1 integer j2 integer y1 integer y2 ! call i_swap ( y1, y2 ) call i_swap ( j1, j2 ) call r_swap ( f1, f2 ) return end subroutine yjf_to_jed_common ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_COMMON converts a Common YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yjf_check_common ( y1, j1, f1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_common ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_common ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_english ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_ENGLISH converts an English YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_english ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_english ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_english ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_gregorian ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_GREGORIAN converts a Gregorian YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_gregorian ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_gregorian ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_gregorian ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_hebrew ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_HEBREW converts a Hebrew YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_hebrew ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_hebrew ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_hebrew ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_islamic_a ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_ISLAMIC_A converts an Islamic-A YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_islamic ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_islamic ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_islamic_a ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_islamic_b ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_ISLAMIC_B converts an Islamic-B YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_islamic ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_islamic ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_islamic_b ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_julian ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_JULIAN converts a Julian YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_julian ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_julian ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_julian ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_republican ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_REPUBLICAN converts a Republican YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_republican ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_republican ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_republican ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_jed_roman ( y, j, f, jed ) ! !******************************************************************************* ! !! YJF_TO_JED_ROMAN converts a Roman YJF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d2 double precision f double precision f1 double precision f2 integer ierror integer j integer j1 integer j2 double precision jed integer m2 integer y integer y1 integer y2 ! ! Copy the input. ! y1 = y j1 = j f1 = f ! ! Check the input. ! call yj_check_roman ( y1, j1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the input. ! call yjf_to_ymdf_roman ( y1, j1, f1, y2, m2, d2, f2 ) call ymdf_to_jed_roman ( y2, m2, d2, f2, jed ) return end subroutine yjf_to_s_common ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_COMMON "prints" a Common YJF date into a string. ! ! ! Format: ! ! CE Y/J.F ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, contains a representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 20 ) s1 character ( len = 3 ) s2 character ( len = 8 ) s3 character ( len = * ) s integer y ! call yjf_check_common ( y, j, f, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'CE ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BCE ' call i_to_s_left ( - y, s1(5:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s1 ) call frac_to_s ( f, s3 ) call s_cat ( s1, s3(1:3), s ) return end subroutine yjf_to_s_english ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_ENGLISH writes an English YJF date into a string. ! ! ! Format: ! ! AD YYYY/JJJ.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_english ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_gregorian ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_GREGORIAN writes a Gregorian YJF date into a string. ! ! ! Format: ! ! AD YYYY/JJJ.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_gregorian ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y >= 0 ) then s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_hebrew ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_HEBREW writes a Hebrew YJF date into a string. ! ! ! Format: ! ! AM YYYY/JJJ.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_hebrew ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AM ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_islamic ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_ISLAMIC writes an Islamic YJF date into a string. ! ! ! Format: ! ! AH YYYY/JJJ.FF ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_islamic ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AH ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_julian ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_JULIAN writes a Julian YJF date into a string. ! ! ! Format: ! ! AD YYYY/JJJ.FF ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_julian ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AD ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_republican ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_REPUBLICAN writes a Republican YJF date into a string. ! ! ! Format: ! ! ER YYYY/JJJ.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_republican ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'ER ' call i_to_s_left ( y, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_s_roman ( y, j, f, s ) ! !******************************************************************************* ! !! YJF_TO_S_ROMAN writes a Roman YJF date into a string. ! ! ! Format: ! ! AUC YYYY/JJJ.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, character ( len = * ) S, the representation of the date. ! implicit none ! double precision f integer ierror integer j character ( len = 11 ) s1 character ( len = 3 ) s2 character ( len = * ) s integer y ! call yj_check_roman ( y, j, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AUC ' call i_to_s_left ( y, s1(5:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( j, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine yjf_to_weekday_common ( y, j, f, w ) ! !******************************************************************************* ! !! YJF_TO_WEEKDAY_COMMON returns the weekday of a Common YJF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer J, double precision F, the YJF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! double precision f double precision f2 integer j double precision jed integer w integer y ! call yjf_to_jed_common ( y, j, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine yjf_to_ymdf_common ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_COMMON converts a Common date from YJF to YMDF format. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yjf_check_common ( y2, j2, f2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! d2 = j2 m2 = 1 call day_borrow_common ( y2, m2, d2 ) call day_carry_common ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_english ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_ENGLISH converts an English date from YJF to YMDF format. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_english ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_english ( y2, m2, d2 ) call day_carry_english ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_gregorian ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_GREGORIAN converts a Gregorian date from YJF to YMDF format. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_gregorian ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_gregorian ( y2, m2, d2 ) call day_carry_gregorian ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_hebrew ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_HEBREW converts a YJF to YMDF date, both in the Hebrew calendar. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_hebrew ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_hebrew ( y2, m2, d2 ) call day_carry_hebrew ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_islamic ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_ISLAMIC converts a YJF to YMDF date, both in the Islamic calendar. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_islamic ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_islamic ( y2, m2, d2 ) call day_carry_islamic ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_julian ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_JULIAN converts a YJF to YMDF date, both in the Julian calendar. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_julian ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_julian ( y2, m2, d2 ) call day_carry_julian ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_republican ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_REPUBLICAN converts a YJF to YMDF date in the Republican calendar. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_republican ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_republican ( y2, m2, d2 ) call day_carry_republican ( y2, m2, d2 ) return end subroutine yjf_to_ymdf_roman ( y1, j1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YJF_TO_YMDF_ROMAN converts a YJF to YMDF date in the Roman calendar. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the ! YMDF date. ! implicit none ! integer d2 double precision f1 double precision f2 integer ierror integer j1 integer j2 integer m2 integer y1 integer y2 ! ! Copy the input. ! y2 = y1 j2 = j1 f2 = f1 ! ! Check the input. ! call yj_check_roman ( y2, j2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if ! ! Convert the input. ! m2 = 1 d2 = j2 call day_borrow_roman ( y2, m2, d2 ) call day_carry_roman ( y2, m2, d2 ) return end subroutine yjf_to_ymdhms_common ( y1, j1, f1, y2, m2, d2, h2, n2, s2 ) ! !******************************************************************************* ! !! YJF_TO_YMDHMS_COMMON converts a Common YJF date to a YMDHMS date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer J1, double precision F1, the YJF date. ! ! Output, integer Y2, integer M2, integer D2, integer H2, integer N2, ! integer S2, the year, month, day, hour, minute and second of the date. ! implicit none ! integer d2 integer d3 double precision f1 double precision f2 integer h2 integer ierror integer j1 integer m2 integer n2 integer s2 integer y1 integer y2 ! call yjf_check_common ( y1, j1, f1, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 h2 = 0 n2 = 0 s2 = 0 end if call yjf_to_ymdf_common ( y1, j1, f1, y2, m2, d2, f2 ) call frac_to_hms ( f2, h2, n2, s2 ) return end subroutine ym_check_alexandrian ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_ALEXANDRIAN checks an Alexandrian YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by the number of months in the PREVIOUS year, and the year is ! decremented by 1. ! ! If the month is greater than the number of months in the CURRENT year, ! then the month is decremented by the number of months in the CURRENT year, ! and the year incremented by 1. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_alexandrian ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_alexandrian ( y, m ) call month_carry_alexandrian ( y, m ) return end subroutine ym_check_bahai ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_BAHAI checks a Bahai YM date. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y integer year_length_months_bahai ! ! Check the year. ! call y_check_bahai ( y, ierror ) if ( ierror /= 0 ) then return end if if ( m < 1 .or. m > year_length_months_bahai ( y ) ) then ierror = 1 return end if return end subroutine ym_check_common ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_COMMON checks a Common YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by 12, and the year decremented by 1, repeatedly, until ! the month is greater than or equal to 1. ! ! If the month is greater than 12, then the month is decremented ! by 12, and the year incremented by 1, repeatedly, until the ! month is less than or equal to 12. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_common ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_common ( y, m ) call month_carry_common ( y, m ) return end subroutine ym_check_eg_civil ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_EG_CIVIL checks an Egyptian Civil YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by the number of months in the PREVIOUS year, and the year is ! decremented by 1. ! ! If the month is greater than the number of months in the CURRENT year, ! then the month is decremented by the number of months in the CURRENT year, ! and the year incremented by 1. ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_eg_civil ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_eg_civil ( y, m ) call month_carry_eg_civil ( y, m ) return end subroutine ym_check_english ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_ENGLISH checks an English YM date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_english ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_english ( y, m ) call month_carry_english ( y, m ) return end subroutine ym_check_gregorian ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_GREGORIAN checks a Gregorian YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by 12, and the year decremented by 1, repeatedly, until ! the month is greater than or equal to 1. ! ! If the month is greater than 12, then the month is decremented ! by 12, and the year incremented by 1, repeatedly, until the ! month is less than or equal to 12. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_gregorian ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_gregorian ( y, m ) call month_carry_gregorian ( y, m ) return end subroutine ym_check_hebrew ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_HEBREW checks a Hebrew YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by the number of months in the PREVIOUS year, and the year is ! decremented by 1. ! ! If the month is greater than the number of months in the CURRENT year, ! then the month is decremented by the number of months in the CURRENT year, ! and the year incremented by 1. ! ! Modified: ! ! 23 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_hebrew ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_hebrew ( y, m ) call month_carry_hebrew ( y, m ) return end subroutine ym_check_islamic ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_ISLAMIC checks an Islamic YM date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_islamic ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_islamic ( y, m ) call month_carry_islamic ( y, m ) return end subroutine ym_check_julian ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_JULIAN checks a Julian YM date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_julian ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_julian ( y, m ) call month_carry_julian ( y, m ) return end subroutine ym_check_republican ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_REPUBLICAN checks a Republican YM date. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer months integer y integer year_length_months_republican ! ! Check the year. ! call y_check_republican ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_republican ( y, m ) call month_carry_republican ( y, m ) return end subroutine ym_check_roman ( y, m, ierror ) ! !******************************************************************************* ! !! YM_CHECK_ROMAN checks a Roman YM date. ! ! ! Discussion: ! ! If the month is less than 1, then the month is incremented ! by the number of months in the PREVIOUS year, and the year is ! decremented by 1. ! ! If the month is greater than the number of months in the CURRENT year, ! then the month is decremented by the number of months in the CURRENT year, ! and the year incremented by 1. ! ! Modified: ! ! 15 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, the YM date. ! ! Output, integer IERROR, is 0 if no error was found in the date, ! and 1 otherwise. ! implicit none ! integer ierror integer m integer y ! ! Check the year. ! call y_check_roman ( y, ierror ) if ( ierror /= 0 ) then return end if ! ! Make sure the month isn't too small or too big. ! call month_borrow_roman ( y, m ) call month_carry_roman ( y, m ) return end subroutine ymd_check_alexandrian ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_ALEXANDRIAN checks an Alexandrian YMD date. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call ym_check_alexandrian ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_alexandrian ( y, m, d ) call day_carry_alexandrian ( y, m, d ) return end subroutine ymd_check_common ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_COMMON checks a Common YMD date. ! ! ! Discussion: ! ! Certain simple errors in dates will be corrected, such as ! "31 September 1996" ! which will become ! "1 October 1996". ! ! The routine also knows that in the Common calendar, the dates ! 5 October 1582 through 14 October 1582 are illegal. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, ! which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m character ( len = 30 ) s integer y ! ierror = 0 ! ! Check the year. ! if ( y == 0 ) then ierror = 1 return end if ! ! Check the month. ! call month_borrow_common ( y, m ) call month_carry_common ( y, m ) ! ! Check the day. ! call day_borrow_common ( y, m, d ) call day_carry_common ( y, m, d ) ! ! Now make sure that the date does not fall in the ! Julian-to-Gregorian calendar switchover limbo. ! if ( y == 1582 ) then if ( m == 10 ) then if ( 5 <= d .and. d <= 14 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'YMD_CHECK_COMMON - Warning!' write ( *, '(a)' ) ' Illegal date:' call ymd_to_s_numeric ( y, m, d, s ) write ( *, '(4x,a)' ) trim ( s ) end if end if end if return end subroutine ymd_check_eg_civil ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_EG_CIVIL checks an Egyptian Civil YMD date. ! ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call ym_check_eg_civil ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_eg_civil ( y, m, d ) call day_carry_eg_civil ( y, m, d ) return end subroutine ymd_check_english ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_ENGLISH checks an English YMD date. ! ! ! Discussion: ! ! Certain simple errors in dates will be corrected, such as ! "31 September 1996" ! which will become ! "1 October 1996". ! ! The routine also knows that in the English calendar, the dates ! 3 September 1752 through 13 September 1752 are illegal. ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m character ( len = 30 ) s integer y ! ! Check the month. ! call ym_check_english ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_english ( y, m, d ) call day_carry_english ( y, m, d ) ! ! Now make sure that the date does not fall in the ! Julian-to-Gregorian calendar switchover limbo. ! if ( y == 1752 ) then if ( m == 9 ) then if ( 3 <= d .and. d <= 13 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'YMD_CHECK_ENGLISH - Warning!' write ( *, '(a)' ) ' Illegal date!' call ymd_to_s_numeric ( y, m, d, s ) write ( *, '(4x,a)' ) trim ( s ) end if end if end if return end subroutine ymd_check_gregorian ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_GREGORIAN checks a Gregorian YMD date. ! ! ! Modified: ! ! 21 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ! Check the month. ! call ym_check_gregorian ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_gregorian ( y, m, d ) call day_carry_gregorian ( y, m, d ) return end subroutine ymd_check_hebrew ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_HEBREW checks a Hebrew YMD date. ! ! ! Modified: ! ! 24 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call ym_check_hebrew ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_hebrew ( y, m, d ) call day_carry_hebrew ( y, m, d ) return end subroutine ymd_check_islamic ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_ISLAMIC checks an Islamic YMD date. ! ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call ym_check_islamic ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_islamic ( y, m, d ) call day_carry_islamic ( y, m, d ) return end subroutine ymd_check_julian ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_JULIAN checks a Julian YMD date. ! ! ! Modified: ! ! 15 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ! Check the month. ! call ym_check_julian ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_julian ( y, m, d ) call day_carry_julian ( y, m, d ) return end subroutine ymd_check_republican ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_REPUBLICAN checks a Republican YMD date. ! ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call ym_check_republican ( y, m, ierror ) if ( ierror /= 0 ) then return end if ! ! Check the day. ! call day_borrow_republican ( y, m, d ) call day_carry_republican ( y, m, d ) return end subroutine ymd_check_roman ( y, m, d, ierror ) ! !******************************************************************************* ! !! YMD_CHECK_ROMAN checks a Roman YMD date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, the YMD date, which may ! be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d integer ierror integer m character ( len = 30 ) s integer y ! ierror = 0 ! ! Check the year. ! if ( y <= 0 ) then ierror = 1 return end if ! ! Check the month. ! call month_borrow_roman ( y, m ) call month_carry_roman ( y, m ) ! ! Check the day. ! call day_borrow_roman ( y, m, d ) call day_carry_roman ( y, m, d ) return end subroutine ymdf_inc_common ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_COMMON increments a Common YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the ! YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the ! incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_common ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_english ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_ENGLISH increments an English YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, the ! incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_english ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_gregorian ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_GREGORIAN increments a Gregorian YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_gregorian ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_hebrew ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_HEBREW increments a Hebrew YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_hebrew ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_islamic ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_ISLAMIC increments an Islamic YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_islamic ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_julian ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_JULIAN increments a Julian YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_julian ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_republican ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_REPUBLICAN increments a Republican YMDF date by DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_republican ( y2, m2, d2, f2, ierror ) return end subroutine ymdf_inc_roman ( y1, m1, d1, f1, days, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_INC_ROMAN increments a Roman YMDF date by a DAYS days. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the YMDF date. ! ! Input, double precision DAYS, the number of days to advance the date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! the incremented YMDF date. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! ! Copy the parameters. ! y2 = y1 m2 = m1 d2 = d1 f2 = f1 + days ! ! Check the parameters. ! call ymdf_check_roman ( y2, m2, d2, f2, ierror ) return end subroutine ymd_inc_ymd_common ( y1, m1, d1, yn, mn, dn, y2, m2, d2 ) ! !******************************************************************************* ! !! YMD_INC_YMD_COMMON increments a Common YMD date by a YMD increment. ! ! ! Discussion: ! ! You often see on old gravestones statements like ! ! "Joe Blow died on May 8 1784 aged 38 Years, 7 Months and 5 Days." ! ! It's not exactly clear how to interpret such a statement, since ! we can't actually convert 38 Years, 7 Months and 5 Days to a number ! of days. (Years and months vary in their day length). However, ! we can assume that what was meant was, if you take the year, month ! and day of Joe Blow's birthday, and you: ! ! add 38 to the year, ! add 7 to the month, and if you go past December, subtract 12 and ! increment the year, ! add 5 to the day, and if you go past the length of the month, ! increment the month and decrement the day appropriately. ! ! Notice, in particular, that if you do the operations in the reverse ! order, you may get a different answer, since what you do with a large ! day value depends on the month you assume you are working in. ! ! Just warning you that this is a poorly posed problem. ! ! Thanks to Charlie Cullen for pointing out this little problem to me. ! ! Modified: ! ! 12 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, the YMD date. ! ! Input, integer YN, integer MN, integer DN, the increment to the YMD date. ! ! Output, integer Y2, integer M2, integer D2, the incremented YMD date. ! implicit none ! integer d1 integer d2 integer dn double precision f1 double precision f2 double precision fn integer ierror integer m1 integer m2 integer mn integer y1 integer y2 integer yn ! ! TEMPORARY ! f1 = 0.0D+00 y2 = y1 + yn m2 = m1 + mn d2 = d1 + dn f2 = f1 + fn call ymdf_check_common ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then y2 = 0 m2 = 0 d2 = 0 f2 = 0.0D+00 return end if return end subroutine ymd_to_s_alexandrian ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_ALEXANDRIAN "prints" an Alexandrian YMD date into a string. ! ! ! Format: ! ! DayNumber MonthName YearNumber AX ! ! Modified: ! ! 13 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 2 ) sd character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_alexandrian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y2, sy ) call month_to_month_name_eg_civil ( m2, sm ) call i_to_s_left ( d2, sd ) call s_cat1 ( sd, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'AX', s ) return end subroutine ymd_to_s_common ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_COMMON writes a Common YMD date into a string. ! ! ! Format: ! ! CE YYYY/MM/DD ! BCE YYYY/MM/DD ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_common ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'CE ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BCE ' call i_to_s_left ( - y2, s1(5:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_eg_civil ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_EG_CIVIL "prints" an Egyptian Civil YMD date into a string. ! ! ! Format: ! ! DayNumber MonthName YearNumber EN ! ! Discussion: ! ! "EN" stands for the Era of Nabonassar, a Babylonian king who ! acceded in 747 BC, used by the astronomer Ptolemy to assign ! an artificial starting year for the Egyptian calendar. ! ! Modified: ! ! 14 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 2 ) sd character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_eg_civil ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y2, sy ) call month_to_month_name_eg_civil ( m2, sm ) call i_to_s_left ( d2, sd ) call s_cat1 ( sd, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'EN', s ) return end subroutine ymd_to_s_eg_lunar ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_EG_LUNAR "prints" an Egyptian Lunar YMD date into a string. ! ! ! Format: ! ! DayNumber MonthName YearNumber EL ! ! Modified: ! ! 16 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer m integer m2 character ( len = 2 ) sd character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d call i_to_s_left ( y2, sy ) call month_to_month_name_eg_lunar ( m2, sm ) call i_to_s_left ( d2, sd ) call s_cat1 ( sd, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'EL', s ) return end subroutine ymd_to_s_english ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_ENGLISH writes an English YMD date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_english ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_gregorian ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_GREGORIAN writes a Gregorian YMD date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_gregorian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_hebrew ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_HEBREW "prints" a Hebrew YMD date into a string. ! ! ! Format: ! ! DayNumber MonthName YearNumber AM ! ! Modified: ! ! 06 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 2 ) sd character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_hebrew ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y2, sy ) call month_to_month_name_hebrew ( y2, m2, sm ) call i_to_s_left ( d2, sd ) call s_cat1 ( sd, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'AM', s ) return end subroutine ymd_to_s_islamic ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_ISLAMIC writes an Islamic YMD date into a string. ! ! ! Format: ! ! DayNumber MonthName YearNumber AH ! ! Modified: ! ! 07 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 2 ) sd character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_islamic ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y2, sy ) call month_to_month_name_islamic ( m2, sm ) call i_to_s_left ( d2, sd ) call s_cat1 ( sd, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'AH', s ) return end subroutine ymd_to_s_julian ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_JULIAN writes a Julian YMD date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD ! ! Modified: ! ! 13 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_julian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_numeric ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_NUMERIC writes a YMD date into a string. ! ! ! Format: ! ! YYYY/MM/DD ! or ! -YYYY/MM/DD ! ! Modified: ! ! 19 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Make local copies of the input. ! y2 = y m2 = m d2 = d call i_to_s_left ( y2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_republican ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_REPUBLICAN writes a Republican YMD date into a string. ! ! ! Format: ! ! ER YYYY/MM/DD ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_republican ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'ER ' call i_to_s_left ( y2, s1(4:) ) else s1 = '-ER ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) return end subroutine ymd_to_s_roman ( y, m, d, s ) ! !******************************************************************************* ! !! YMD_TO_S_ROMAN writes a Roman YMD date into a string. ! ! ! Example: ! ! Y M D S ! -- - -- ----------------------------------- ! 56 4 1 Kalends Aprilis DVI AUC ! 56 4 2 Ante diem iv Nones Aprilis DVI AUC ! 56 4 3 Ante diem iii Nones Aprilis DVI AUC ! 56 4 4 Pridie Nones Aprilis DVI AUC ! 56 4 5 Nones Aprilis DVI AUC ! 56 4 6 Ante diem viii Ides Aprilis DVI AUC ! 56 4 7 Ante diem vii Ides Aprilis DVI AUC ! 56 4 8 Ante diem vi Ides Aprilis DVI AUC ! 56 4 9 Ante diem v Ides Aprilis DVI AUC ! 56 4 10 Ante diem iv Ides Aprilis DVI AUC ! 56 4 11 Ante diem iii Ides Aprilis DVI AUC ! 56 4 12 Pridie Ides Aprilis DVI AUC ! 56 4 13 Ides Aprilis DVI AUC ! 56 4 14 Ante diem xvii Kalends Maius DVI AUC ! 56 4 15 Ante diem xvi Kalends Maius DVI AUC ! ... ! 56 4 28 Ante diem iv Kalends Maius DVI AUC ! 56 4 29 Ante diem iii Kalends Maius DVI AUC ! 56 4 30 Pridie Kalends Maius DVI AUC ! ! Discussion: ! ! "AUC" means "ab urbe condita", or "from the founding of the city". ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, the YMD date. ! ! Output, character ( len = * ) S, a string representing the date. ! implicit none ! integer d integer d2 integer i_wrap integer iday integer ides integer ierror integer jday integer last character ( len = 10 ) lower integer m integer m2 integer m3 integer month_length_roman integer nones character ( len = * ) s character ( len = 10 ) s_day character ( len = 15 ) s_month character ( len = 15 ) s_month_next character ( len = 10 ) s_year integer y integer y2 logical year_is_leap_roman ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_roman ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call month_to_month_name_roman ( m2, s_month ) ! ! Get the next month's name. ! m3 = i_wrap ( m2+1, 1, 12 ) call month_to_month_name_roman ( m3, s_month_next ) call month_to_nones_roman ( m2, nones ) call month_to_ides_roman ( m2, ides ) last = month_length_roman ( y2, m2 ) if ( d2 == 1 ) then s = 'Kalends ' // s_month else if ( d2 < nones - 1 ) then jday = nones + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Nones ' // s_month else if ( d2 == nones - 1 ) then s = 'Pridie Nones ' // s_month else if ( d2 == nones ) then s = 'Nones ' // s_month else if ( d2 < ides - 1 ) then jday = ides + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Ides ' // s_month else if ( d2 == ides - 1 ) then s = 'Pridie Ides ' // s_month else if ( d2 == ides ) then s = 'Ides ' // s_month else if ( m2 == 2 .and. year_is_leap_roman ( y2 ) ) then if ( d2 < 25 ) then jday = last + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( d2 == 25 ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem Bis ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( d2 < last ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s = 'Pridie Kalends ' // s_month_next end if else if ( d2 < last ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s = 'Pridie Kalends ' // s_month_next end if call i_to_roman ( y2, s_year ) call s_cat1 ( s, s_year, s ) call s_cat ( s, ' AUC', s ) return end subroutine ymdf_check_common ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_COMMON checks a Common YMDF date. ! ! ! Discussion: ! ! Certain simple errors in dates will be corrected, such as ! "31 September 1996" ! which will become ! "1 October 1996". ! ! The routine also knows that in the Common calendar, the dates ! 5 October 1582 through 14 October 1582 are illegal. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m character ( len = 30 ) s integer y ! ierror = 0 call ymd_check_common ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_common ( y, m, d, f ) call frac_carry_common ( y, m, d, f ) return end subroutine ymdf_check_english ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_ENGLISH checks an English YMDF date. ! ! ! Discussion: ! ! Certain simple errors in dates will be corrected, such as ! "31 September 1996" ! which will become ! "1 October 1996". ! ! The routine also knows that in the English calendar, the dates ! 3 September 1752 through 13 September 1752 are illegal. ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m character ( len = 30 ) s integer y ! ierror = 0 call ymd_check_english ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_english ( y, m, d, f ) call frac_carry_english ( y, m, d, f ) return end subroutine ymdf_check_gregorian ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_GREGORIAN checks a Gregorian YMDF date. ! ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m integer y ! ierror = 0 call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_gregorian ( y, m, d, f ) call frac_carry_gregorian ( y, m, d, f ) return end subroutine ymdf_check_hebrew ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_HEBREW checks a Hebrew YMDF date. ! ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m integer y ! ierror = 0 call ymd_check_hebrew ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_hebrew ( y, m, d, f ) call frac_carry_hebrew ( y, m, d, f ) return end subroutine ymdf_check_islamic ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_ISLAMIC checks an Islamic YMDF date. ! ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m integer y ! ierror = 0 call ymd_check_islamic ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_islamic ( y, m, d, f ) call frac_carry_islamic ( y, m, d, f ) return end subroutine ymdf_check_julian ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_JULIAN checks a Julian YMDF date. ! ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m integer y ! ierror = 0 call ymd_check_julian ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_julian ( y, m, d, f ) call frac_carry_julian ( y, m, d, f ) return end subroutine ymdf_check_republican ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_REPUBLICAN checks a Republican YMDF date. ! ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m integer y ! ierror = 0 call ymd_check_republican ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_republican ( y, m, d, f ) call frac_carry_republican ( y, m, d, f ) return end subroutine ymdf_check_roman ( y, m, d, f, ierror ) ! !******************************************************************************* ! !! YMDF_CHECK_ROMAN checks a Roman YMDF date. ! ! ! Modified: ! ! 15 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer Y, integer M, integer D, double precision F, the ! YMDF date, which may be corrected if necessary and possible. ! ! Output, integer IERROR, is 0 if the date is legal. ! implicit none ! integer d double precision f integer ierror integer m character ( len = 30 ) s integer y ! ierror = 0 call ymd_check_roman ( y, m, d, ierror ) if ( ierror /= 0 ) then return end if call frac_borrow_roman ( y, m, d, f ) call frac_carry_roman ( y, m, d, f ) return end subroutine ymdf_compare ( y1, m1, d1, f1, y2, m2, d2, f2, cmp ) ! !******************************************************************************* ! !! YMDF_COMPARE compares two YMD dates. ! ! ! Discussion: ! ! The comparison should work for a pair of dates in any calendar. ! ! No check is made that the dates are actually legitimate. It is ! assumed that the calling routine has already ensured that the ! dates are properly "normalized". ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the ! first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, the ! second YMDF date. ! ! Output, character CMP: ! '<' if date 1 precedes date 2; ! '=' if date 1 equals date 2; ! '>' if date 1 follows date 2; ! implicit none ! character cmp integer d1 integer d2 double precision f1 double precision f2 integer ierror integer m1 integer m2 integer y1 integer y2 ! cmp = '?' ! ! Compare years... ! if ( y1 < y2 ) then cmp = '<' else if ( y1 > y2 ) then cmp = '>' else ! ! ...if necessary, compare months in equal years... ! if ( m1 < m2 ) then cmp = '<' else if ( m1 > m2 ) then cmp = '>' else ! ! ...if necessary, compare days in equal months... ! if ( d1 < d2 ) then cmp = '<' else if ( d1 > d2 ) then cmp = '>' else ! ! ...if necessary, compare fractional parts. ! if ( f1 < f2 ) then cmp = '<' else if ( f1 > f2 ) then cmp = '>' else cmp = '=' end if end if end if end if return end subroutine ymdf_dif_common ( y1, m1, d1, f1, y2, m2, d2, f2, days, ierror ) ! !******************************************************************************* ! !! YMDF_DIF_COMMON gets the day difference between two Common YMDF dates. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, ! the first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, ! the second YMDF date. ! ! Output, double precision DAYS, the number of days between the two dates. ! ! Output, integer IERROR, is 1 if either date is illegal, ! 0 otherwise. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror double precision jed1 double precision jed2 integer m1 integer m2 integer y1 integer y2 ! days = 0.0D+00 ! ! Check the dates. ! call ymdf_check_common ( y1, m1, d1, f1, ierror ) if ( ierror /= 0 ) then return end if call ymdf_check_common ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then return end if call ymdf_to_jed_common ( y1, m1, d1, f1, jed1 ) call ymdf_to_jed_common ( y2, m2, d2, f2, jed2 ) days = jed2 - jed1 return end subroutine ymdf_dif_english ( y1, m1, d1, f1, y2, m2, d2, f2, days, ierror ) ! !******************************************************************************* ! !! YMDF_DIF_ENGLISH gets the day difference between two English YMDF dates. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, the first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, the second YMDF date. ! ! Output, double precision DAYS, the number of days between the two dates. ! ! Output, integer IERROR, is 1 if either date is illegal, ! 0 otherwise. ! implicit none ! integer d1 integer d2 double precision days double precision f1 double precision f2 integer ierror double precision jed1 double precision jed2 integer m1 integer m2 integer y1 integer y2 ! days = 0.0D+00 ! ! Check the dates. ! call ymdf_check_english ( y1, m1, d1, f1, ierror ) if ( ierror /= 0 ) then return end if call ymdf_check_english ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then return end if call ymdf_to_jed_english ( y1, m1, d1, f1, jed1 ) call ymdf_to_jed_english ( y2, m2, d2, f2, jed2 ) days = jed2 - jed1 return end subroutine ymdf_dif_ymdf_common ( y1, m1, d1, f1, y2, m2, d2, f2, yn, mn, & dn, fn, ierror ) ! !******************************************************************************* ! !! YMDF_DIF_YMDF_COMMON gets the YMDF difference between two Common YMDF dates. ! ! ! Discussion: ! ! This difference is not well defined. A reasonable way to define this ! difference is: ! ! Use Y1, M1, D1, F1 as a base, ! ! Increment Y1 by 1 repeatedly, until your date is less than ! a year before Y2/M2/D2/F2. ! ! Increment M1 by 1 repeatedly, until your date is less than a ! month before Y2/M2/D2/F2. ! ! Increment D1 by 1 repeatedly, until your data is less than a ! day before Y2/M2/D2/F2. ! ! Measure the fractional day difference. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the ! first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, the ! second YMDF date. ! ! Output, integer YN, integer MN, integer DN, double precision FN, ! the difference in years, months, days, and fractional days from the ! first date to the second. ! ! Output, integer IERROR, is 1 if either date is illegal, ! 0 otherwise. ! implicit none ! character cmp integer d1 integer d2 integer dn double precision f1 double precision f2 double precision fn integer ierror integer m1 integer m2 integer m3 integer mn integer month_length_common integer y1 integer y2 integer y3 integer yn ! ! Check the dates. ! call ymdf_check_common ( y1, m1, d1, f1, ierror ) if ( ierror /= 0 ) then return end if call ymdf_check_common ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then return end if ! ! Compare the dates. ! call ymdf_compare ( y1, m1, d1, f1, y2, m2, d2, f2, cmp ) ! ! We swap dates, if necessary, so that date 1 is never greater ! than date 2. ! if ( cmp == '=' ) then yn = 0 mn = 0 dn = 0 fn = 0.0D+00 return else if ( cmp == '>' ) then call ymdf_swap ( y1, m1, d1, f1, y2, m2, d2, f2 ) end if ! ! Year difference. ! yn = y2 - y1 ! ! Month difference. ! y3 = y2 if ( m1 > m2 ) then yn = yn - 1 mn = m2 - m1 + 12 y3 = y2 - 1 else mn = m2 - m1 end if m3 = m2 ! ! Day difference. ! if ( d1 > d2 ) then mn = mn - 1 m3 = m2 - 1 if ( m3 == 0 ) then m3 = 12 y3 = y3 - 1 end if dn = d2 - d1 + month_length_common ( y3, m3 ) else dn = d2 - d1 end if ! ! Fractional difference. ! THERE'S MORE TO THIS CODE, AFTER ALL, WHAT IF DN < 0? ! if ( f1 > f2 ) then dn = dn - 1 end if fn = f2 - f1 return end subroutine ymdf_next_common ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_COMMON returns the Common YMDF date of the next day. ! ! ! Discussion: ! ! The routine knows that in the Common calendar, the day after ! 4 October 1582 was 15 October 1582. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_common ( y2, m2, d2 ) return end subroutine ymdf_next_english ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_ENGLISH returns the English YMD date of the next day. ! ! ! Discussion: ! ! The routine knows that in the English calendar, ! the day after 2 September 1752 was 14 September 1752. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_english ( y2, m2, d2 ) return end subroutine ymdf_next_gregorian ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_GREGORIAN returns the Gregorian YMDF date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_gregorian ( y2, m2, d2 ) return end subroutine ymdf_next_hebrew ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_HEBREW returns the Hebrew YMDF date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_hebrew ( y2, m2, d2 ) return end subroutine ymdf_next_islamic ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_ISLAMIC returns the Islamic YMDF date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_islamic ( y2, m2, d2 ) return end subroutine ymdf_next_julian ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_JULIAN returns the Julian YMDF date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_julian ( y2, m2, d2 ) return end subroutine ymdf_next_republican ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_REPUBLICAN returns the Republican YMD date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_republican ( y2, m2, d2 ) return end subroutine ymdf_next_roman ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_NEXT_ROMAN returns the Roman YMDF date of the next day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, tomorrow's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 + 1 f2 = f1 call day_carry_roman ( y2, m2, d2 ) return end subroutine ymdf_prev_common ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_COMMON returns the Common YMDF date of the previous day. ! ! ! Discussion: ! ! The routine knows that in the Common calendar, the day before ! 15 October 1582 was 4 October 1582. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_common ( y2, m2, d2 ) return end subroutine ymdf_prev_english ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_ENGLISH returns the English YMDF date of the previous day. ! ! ! Discussion: ! ! The routine knows that in the English calendar, ! the day before 14 September 1752 was 2 September 1752. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_english ( y2, m2, d2 ) return end subroutine ymdf_prev_gregorian ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_GREGORIAN returns the Gregorian YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_gregorian ( y2, m2, d2 ) return end subroutine ymdf_prev_hebrew ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_HEBREW returns the Hebrew YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_hebrew ( y2, m2, d2 ) return end subroutine ymdf_prev_islamic ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_ISLAMIC returns the Islamic YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_islamic ( y2, m2, d2 ) return end subroutine ymdf_prev_julian ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_JULIAN returns the Julian YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_julian ( y2, m2, d2 ) return end subroutine ymdf_prev_republican ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_REPUBLICAN returns the Republican YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_republican ( y2, m2, d2 ) return end subroutine ymdf_prev_roman ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_PREV_ROMAN returns the Roman YMDF date of the previous day. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the YMDF date. ! ! Output, integer Y2, integer M2, integer D2, double precision F2, ! yesterday's YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! y2 = y1 m2 = m1 d2 = d1 - 1 f2 = f1 call day_borrow_roman ( y2, m2, d2 ) return end subroutine ymdf_random_common ( y1, m1, d1, f1, y2, m2, d2, f2, y, m, d, f ) ! !******************************************************************************* ! !! YMDF_RANDOM_COMMON picks a random Common YMDF date between two given dates. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, the second YMDF date. ! ! Output, integer Y, integer M, integer D, double precision F, the random YMDF date. ! implicit none ! integer d integer d1 integer d2 integer f integer f1 integer f2 double precision jed double precision jed1 double precision jed2 integer m integer m1 integer m2 integer y integer y1 integer y2 ! call ymdf_to_jed_common ( y1, m1, d1, f1, jed1 ) call ymdf_to_jed_common ( y2, m2, d2, f2, jed2 ) call d_random ( jed1, jed2, jed ) call jed_to_ymdf_common ( jed, y, m, d, f ) return end subroutine ymdf_random_english ( y1, m1, d1, f1, y2, m2, d2, f2, y, m, d, f ) ! !******************************************************************************* ! !! YMDF_RANDOM_ENGLISH picks a random English YMDF date between two given dates. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, the second YMDF date. ! ! Output, integer Y, integer M, integer D, double precision F, the ! random YMDF date. ! implicit none ! integer d integer d1 integer d2 integer f integer f1 integer f2 double precision jed double precision jed1 double precision jed2 integer m integer m1 integer m2 integer y integer y1 integer y2 ! call ymdf_to_jed_english ( y1, m1, d1, f1, jed1 ) call ymdf_to_jed_english ( y2, m2, d2, f2, jed2 ) call d_random ( jed1, jed2, jed ) call jed_to_ymdf_english ( jed, y, m, d, f ) return end subroutine ymdf_swap ( y1, m1, d1, f1, y2, m2, d2, f2 ) ! !******************************************************************************* ! !! YMDF_SWAP swaps two YMDF dates. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y1, integer M1, integer D1, double precision F1, the ! first YMDF date. ! ! Input, integer Y2, integer M2, integer D2, double precision F2, the ! second YMDF date. ! implicit none ! integer d1 integer d2 double precision f1 double precision f2 integer m1 integer m2 integer y1 integer y2 ! call i_swap ( y1, y2 ) call i_swap ( m1, m2 ) call i_swap ( d1, d2 ) call r_swap ( f1, f2 ) return end subroutine ymdf_to_jed_alexandrian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ALEXANDRIAN converts an Alexandrian YMDF date to a JED. ! ! ! Discussion: ! ! This code needs to be adjusted to fit the Alexandrian model. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 4690 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( ( 1461 * y_prime ) / 4 + 30 * m_prime + d_prime - 124 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_armenian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ARMENIAN converts an Armenian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 5268 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( 365 * y_prime + 30 * m_prime + d_prime - 317 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_bahai ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_BAHAI converts a Bahai YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f integer g double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 6560 - ( 39 - m ) / 20 m_prime = mod ( m, 20 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = 19 * m_prime g = 3 * ( ( y_prime + 184 ) / 100 ) / 4 - 50 jed = dble ( j1 + j2 + d_prime - 1412 - g ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_common ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_COMMON converts a Common YMDF date to a JED. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! The Julian Ephemeris Date is essentially a count of the number ! of days that have elapsed since noon, 1 January 4713 BC, at ! Greenwich, England. Strictly speaking, the Julian Ephemeris Date ! is counted from noon, and thus day "0" began at noon on 1 January 4713 BC, ! and ended at noon on 2 January 4713 BC. ! ! The Julian Ephemeris Date was devised by Joseph Scaliger in 1583. ! ! The Julian Ephemeris Date has been adopted by astronomers as ! a convenient reference for dates. ! ! Examples: ! ! Y M D JED ! -------------- ------- ! BC 4713 Jan 1 0 ! AD 1968 May 23 2440000 ! AD 1984 Dec 31 2446065 ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! character cmp integer d integer d1 integer d2 double precision f double precision f1 double precision f2 integer ierror double precision jed integer m integer m1 integer m2 integer y integer y1 integer y2 ! ! Copy the month and year. ! y1 = y m1 = m d1 = d f1 = f call ymdf_check_common ( y1, m1, d1, f1, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if y2 = 1582 m2 = 10 d2 = 4+1 f2 = 0.0D+00 call ymdf_compare ( y1, m1, d1, f1, y2, m2, d2, f2, cmp ) if ( cmp == '<' ) then call ymdf_to_jed_julian ( y1, m1, d1, f1, jed ) return end if ! ! Use the Gregorian calendar for dates strictly after 1752/9/13. ! y2 = 1582 m2 = 10 d2 = 15-1 f2 = 0.0D+00 call ymdf_compare ( y1, m1, d1, f1, y2, m2, d2, f2, cmp ) if ( cmp == '>' ) then call ymdf_to_jed_gregorian ( y1, m1, d1, f1, jed ) return end if jed = -1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'YMDF_TO_JED_COMMON - Error!' write ( *, '(a)' ) ' Illegal date!' return end subroutine ymdf_to_jed_coptic ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_COPTIC converts a Coptic YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 4996 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( ( 1461 * y_prime ) / 4 + 30 * m_prime + d_prime - 124 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_eg_civil ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_EG_CIVIL converts an Egyptian Civil YMDF date to a JED. ! ! ! Discussion: ! ! The Egyptian Civil calendar used a year of 365 days. The year comprised ! 12 months of 30 days, with 5 epagomenal days occurring at the end of ! the year. Since the observed year is about 365.25 days long, and no ! attempt was made to adjust the Egyptian Civil year to the observed year, ! the calendar dates gradually drifted with respect to the observed dates. ! ! The epoch or first day of the Egyptian Civil calendar is taken as ! JED = 1448638.5. ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 3968 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( 365 * y_prime + 30 * m_prime + d_prime - 47 + 1 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_eg_lunar ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_EG_LUNAR converts an Egyptian Lunar YMDF date to a JED. ! ! ! Discussion: ! ! Count ! the days up to the day before the start of the calendar, ! the days in the current month, ! the 29 days guaranteed in the previous months of this year, ! the (months/2) 30th days in the previous months of this year, ! the 354 days guaranteed in each of the previous years, ! the extra leap days in the preceding years, ! the extra 30 days in the leap months in the preceding years. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d double precision f integer ierror double precision jed double precision jed_epoch integer m integer y ! ierror = 0 call epoch_to_jed_eg_lunar ( jed_epoch ) jed = jed_epoch + dble ( - 1 + d + 29 * ( m - 1 ) + ( m - 1 ) / 2 & + 354 * ( y - 1 ) + ( y - 1 ) / 5 & + 30 * ( ( ( y - 1 ) / 25 ) * 9 + ( mod ( ( y - 1 ), 25 ) + 2 ) / 3 ) ) jed = jed + f return end subroutine ymdf_to_jed_english ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ENGLISH converts an English YMDF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! character ( len = 1 ) cmp integer d integer d1 integer d2 double precision f double precision f1 double precision f2 integer ierror double precision jed integer m integer m1 integer m2 integer y integer y1 integer y2 ! ! Check the date. ! call ymd_check_english ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Use the Julian Calendar for dates strictly before 1752/9/3. ! y1 = 1752 m1 = 9 d1 = 3 f1 = 0.0D+00 call ymdf_compare ( y, m, d, f, y1, m1, d1, f1, cmp ) if ( cmp == '<' ) then call ymdf_to_jed_julian ( y, m, d, f, jed ) return end if ! ! Use the Gregorian calendar for dates strictly after 1752/9/13. ! y2 = 1752 m2 = 9 d2 = 13 f2 = 0.0D+00 call ymdf_compare ( y, m, d, f, y2, m2, d2, f2, cmp ) if ( cmp == '>' ) then call ymdf_to_jed_gregorian ( y, m, d, f, jed ) return end if ! ! Error return if the date falls between the transition dates. ! jed = -1.0D+00 return end subroutine ymdf_to_jed_ethiopian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ETHIOPIAN converts an Ethiopian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 4720 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = 30 * m_prime jed = dble ( j1 + j2 + d_prime - 124 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_gregorian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_GREGORIAN converts a Gregorian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding JED. ! implicit none ! integer d integer d_prime double precision f integer g integer ierror double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y2 integer y_prime ! ! Check the date. ! call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Account for the missing year 0 by moving negative years up one. ! call y_common_to_astronomical ( y, y2 ) ! ! Convert the calendar date to a computational date. ! y_prime = y2 + 4716 - ( 14 - m ) / 12 m_prime = mod ( m + 9, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = ( 153 * m_prime + 2 ) / 5 g = 3 * ( ( y_prime + 184 ) / 100 ) / 4 - 38 jed = dble ( j1 + j2 + d_prime - 1401 - g ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_hebrew ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_HEBREW converts a Hebrew YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm J, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 334. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding JED. ! implicit none ! integer d double precision f integer ierror double precision jed integer m integer m2 integer month_length_hebrew integer y ! ! Check the date. ! call ymd_check_hebrew ( y, m, d, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'YMDF_TO_JED_HEBREW - Fatal error!' write ( *, '(a)' ) ' Illegal date!' write ( *, '(a,3i6)' ) ' Y/M/D = ', y, m, d jed = -1.0D+00 return end if ! ! Determine the JED of the beginning of the year. ! call new_year_to_jed_hebrew ( y, jed ) ! ! Work through the preceding months. ! do m2 = 1, m - 1 jed = jed + dble ( month_length_hebrew ( y, m2 ) ) end do ! ! Add on the days. ! jed = jed + dble ( d - 1 ) jed = jed + f return end subroutine ymdf_to_jed_hindu_solar ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_HINDU_SOLAR converts a Hindu solar YMDF date to a JED. ! ! ! Reference: ! ! E Reingold, N Dershowitz, S Clamen, ! Calendrical Calculations, II: Three Historical Calendars, ! Software - Practice and Experience, ! Volume 23, Number 4, pages 383-404, April 1993. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d double precision f double precision jed double precision jed_epoch integer m double precision month_length_hindu_solar integer y double precision year_length_hindu_solar ! call epoch_to_jed_hindu_solar ( jed_epoch ) jed = jed_epoch + dble ( & + dble ( d - 1 ) & + dble ( m - 1 ) * month_length_hindu_solar ( ) & + dble ( y ) * year_length_hindu_solar ( ) ) jed = jed + f return end subroutine ymdf_to_jed_islamic_a ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ISLAMIC_A converts an Islamic A YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f integer ierror double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Check the date. ! call ymd_check_islamic ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the calendar date to a computational date. ! y_prime = y + 5519 - ( 12 - m ) / 12 m_prime = mod ( m + 11, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 10631 * y_prime + 14 ) / 30 j2 = ( 2951 * m_prime + 51 ) / 100 jed = dble ( j1 + j2 + d_prime - 7665 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_islamic_a2 ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ISLAMIC_A2 converts an Islamic A YMDF date to a JED. ! ! ! Discussion: ! ! The algorithm has the beauty of being comprehensible! ! ! Count the days up to the day before the start of the calendar, ! plus the days in the current month, the 29 days guaranteed ! in the previous months of this year, the (months/2) 30th days, ! the 354 days in each of the previous years, plus the total number ! of leap days in the preceding years. ! ! Reference: ! ! E Reingold, N Dershowitz, ! Calendrical Calculations I, ! Software - Practice and Experience, ! Volume 20, Number 9, September 1990, pages 899-928. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d double precision f integer ierror double precision jed double precision jed_epoch integer m integer y ! ! Check the date. ! call ymd_check_islamic ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if call epoch_to_jed_islamic_a ( jed_epoch ) jed = jed_epoch + dble ( - 1 + d + 29 * ( m - 1 ) + ( m / 2 ) & + 354 * ( y - 1 ) + ( 11 * y + 3 ) / 30 ) jed = jed + f return end subroutine ymdf_to_jed_islamic_b ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ISLAMIC_B converts an Islamic B YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f integer ierror double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Check the date. ! call ymd_check_islamic ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the calendar date to a computational date. ! y_prime = y + 5519 - ( 12 - m ) / 12 m_prime = mod ( m + 11, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 10631 * y_prime + 14 ) / 30 j2 = ( 2951 * m_prime + 51 ) / 100 jed = dble ( j1 + j2 + d_prime - 7664 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_jelali ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_JELALI converts a Jelali YMDF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d double precision f double precision jed double precision jed_epoch integer m integer y ! call epoch_to_jed_jelali ( jed_epoch ) jed = jed_epoch + dble ( ( d - 1 ) + 30 * ( m - 1 ) + 365 * ( y - 1 ) & + ( y - 1 ) / 4 ) jed = jed + f return end subroutine ymdf_to_jed_julian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_JULIAN converts a Julian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f integer ierror double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y2 integer y_prime ! ! Check the date. ! call ymdf_check_julian ( y, m, d, f, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Account for the missing year 0 by moving negative years up one. ! call y_common_to_astronomical ( y, y2 ) ! ! Convert the calendar date to a computational date. ! y_prime = y2 + 4716 - ( 14 - m ) / 12 m_prime = mod ( m + 9, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = ( 153 * m_prime + 2 ) / 5 jed = dble ( j1 + j2 + d_prime - 1401 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_julian2 ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_JULIAN2 converts a Julian YMDF date to a JED. ! ! ! Examples: ! ! Y M D JED ! -------------- ------- ! BC 4713 1 1 0 ! AD 1 1 1 1721424 ! AD 1844 5 11 2394710 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d integer d2 integer days_before_month_julian double precision f integer ierror double precision jed integer m integer m2 integer y integer y2 integer y3 integer y4 ! y2 = y m2 = m d2 = d call ymd_check_julian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Account for the missing year 0 by moving negative years up one. ! call y_common_to_astronomical ( y2, y3 ) ! ! The JED is the number of days in years past, plus the number of days in ! the previous months this year, plus the number of days. ! jed = dble ( ( ( 1461 * ( y3 + 4715 ) ) / 4 ) - 1095 & + days_before_month_julian ( y2, m2 ) + d2 - 1 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_khwarizmian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_KHWARIZMIAN converts a Khwarizmian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 5348 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( 365 * y_prime + 30 * m_prime + d_prime - 317 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_macedonian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_MACEDONIAN converts a Macedonian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 4405 - ( 18 - m ) / 12 m_prime = mod ( m + 5, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = ( 153 * m_prime + 2 ) / 5 jed = dble ( j1 + j2 + d_prime - 1401 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_persian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_PERSIAN converts a Persian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 5348 - ( 22 - m ) / 13 m_prime = mod ( m + 3, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! jed = dble ( 365 * y_prime + 30 * m_prime + d_prime - 77 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_republican ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_REPUBLICAN converts a Republican YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding JED. ! implicit none ! integer d integer d_prime double precision f integer g integer ierror double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Check the date. ! call ymd_check_republican ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if ! ! Convert the calendar date to a computational date. ! y_prime = y + 6504 - ( 13 - m ) / 13 m_prime = mod ( m + 12, 13 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = 30 * m_prime g = 3 * ( ( y_prime + 396 ) / 100 ) / 4 - 51 jed = dble ( j1 + j2 + d_prime - 111 - g ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_roman ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ROMAN converts a Roman YMDF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the Julian Ephemeris Date. ! implicit none ! integer d double precision f integer ierror double precision jed integer m integer y integer y2 ! ! Check the date. ! call ymd_check_roman ( y, m, d, ierror ) if ( ierror /= 0 ) then jed = -1.0D+00 return end if call y_roman_to_julian ( y, y2 ) call ymdf_to_jed_julian ( y2, m, d, f, jed ) return end subroutine ymdf_to_jed_saka ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_SAKA converts a Saka YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding JED. ! implicit none ! integer d integer d_prime double precision f integer g double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime integer z ! ! Convert the calendar date to a computational date. ! y_prime = y + 4794 - ( 13 - m ) / 12 m_prime = mod ( m + 10, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 z = m_prime / 6 j2 = ( 31 - z ) * m_prime + 5 * z g = 3 * ( ( y_prime + 184 ) / 100 ) / 4 - 36 jed = dble ( j1 + j2 + d_prime - 1348 - g ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_soor_san ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_SOOR_SAN converts a Soor San YMDF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d double precision f double precision jed double precision jed_epoch integer m integer y ! call epoch_to_jed_soor_san ( jed_epoch ) jed = jed_epoch + dble ( ( d - 1 ) + 30 * ( m - 1 ) + 365 * ( y - 1 ) & + ( y - 1 ) / 4 ) jed = jed + f return end subroutine ymdf_to_jed_syrian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_SYRIAN converts a Syrian YMDF date to a JED. ! ! ! Reference: ! ! E G Richards, ! Algorithm E, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 323-324. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d integer d_prime double precision f double precision jed integer j1 integer j2 integer m integer m_prime integer y integer y_prime ! ! Convert the calendar date to a computational date. ! y_prime = y + 4405 - ( 17 - m ) / 12 m_prime = mod ( m + 6, 12 ) d_prime = d - 1 ! ! Convert the computational date to a JED. ! j1 = ( 1461 * y_prime ) / 4 j2 = ( 153 * m_prime + 2 ) / 5 jed = dble ( j1 + j2 + d_prime - 1401 ) - 0.5D+00 jed = jed + f return end subroutine ymdf_to_jed_zoroastrian ( y, m, d, f, jed ) ! !******************************************************************************* ! !! YMDF_TO_JED_ZOROASTRIAN converts a Zoroastrian YMDF date to a JED. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, double precision JED, the corresponding Julian Ephemeris Date. ! implicit none ! integer d double precision f double precision jed double precision jed_epoch integer m integer y ! call epoch_to_jed_zoroastrian ( jed_epoch ) jed = jed_epoch + dble ( ( d - 1 ) + 30 * ( m - 1 ) + 365 * ( y - 1 ) ) jed = jed + f return end subroutine ymdf_to_s_common ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_COMMON writes a Common YMDF date into a string. ! ! ! Format: ! ! CE YYYY/MM/DD.FF ! BCE YYYY/MM/DD.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymdf_check_common ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'CE ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BCE ' call i_to_s_left ( - y2, s1(5:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f2, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_english ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_ENGLISH writes an English YMDF date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD.FF ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymd_check_english ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f2, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_gregorian ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_GREGORIAN writes a Gregorian YMDF date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD.FF ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymd_check_gregorian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f2, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_hebrew ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_HEBREW "prints" a Hebrew YMDF date into a string. ! ! ! Format: ! ! DayNumber.Fraction MonthName YearNumber AM ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 2 ) sd character ( len = 3 ) sf character ( len = 10 ) sm character ( len = 10 ) sy character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymd_check_hebrew ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call i_to_s_left ( y2, sy ) call month_to_month_name_hebrew ( y2, m2, sm ) call i_to_s_left ( d2, sd ) call frac_to_s ( f2, sf ) call s_cat ( sd, sf, s ) call s_cat1 ( s, sm, s ) call s_cat1 ( s, sy, s ) call s_cat1 ( s, 'AM', s ) return end subroutine ymdf_to_s_islamic ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_ISLAMIC writes an Islamic YMDF date into a string. ! ! ! Format: ! ! AH YYYY/MM/DD.FF ! ! Modified: ! ! 19 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymd_check_islamic ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if s1 = 'AH ' call i_to_s_left ( y2, s1(4:) ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_julian ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_JULIAN writes a Julian YMDF date into a string. ! ! ! Format: ! ! AD YYYY/MM/DD.FF ! ! Modified: ! ! 17 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d f2 = f ! ! Check the input. ! call ymd_check_julian ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'AD ' call i_to_s_left ( y2, s1(4:) ) else s1 = 'BC ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_numeric ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_NUMERIC writes a YMDF date into a string. ! ! ! Format: ! ! YYYY/MM/DD.FF ! or ! -YYYY/MM/DD.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f double precision f2 integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Make local copies of the input. ! y2 = y m2 = m d2 = d f2 = f call i_to_s_left ( y2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_republican ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_REPUBLICAN writes a Republican YMDF date into a string. ! ! ! Format: ! ! ER YYYY/MM/DD.FF ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a representation of the date. ! implicit none ! integer d integer d2 double precision f integer ierror integer m integer m2 character ( len = 20 ) s1 character ( len = 2 ) s2 character ( len = * ) s integer y integer y2 ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_republican ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if if ( y2 >= 0 ) then s1 = 'ER ' call i_to_s_left ( y2, s1(4:) ) else s1 = '-ER ' call i_to_s_left ( - y2, s1(4:) ) end if call s_cat ( s1, '/', s1 ) call i_to_s_zero ( m2, s2 ) call s_cat ( s1, s2, s1 ) call s_cat ( s1, '/', s1 ) call i_to_s_zero ( d2, s2 ) call s_cat ( s1, s2, s ) call frac_to_s ( f, s1 ) call s_cat ( s, s1(1:3), s ) return end subroutine ymdf_to_s_roman ( y, m, d, f, s ) ! !******************************************************************************* ! !! YMDF_TO_S_ROMAN writes a Roman YMDF date into a string. ! ! ! Example: ! ! Y M D F S ! -- - -- --- ----------------------------------- ! 56 4 1 0.1 Kalends Aprilis DVI AUC ! 56 4 2 0.2 Ante diem iv Nones Aprilis DVI AUC ! 56 4 3 0.3 Ante diem iii Nones Aprilis DVI AUC ! 56 4 4 0.4 Pridie Nones Aprilis DVI AUC ! 56 4 5 0.5 Nones Aprilis DVI AUC ! 56 4 6 0.6 Ante diem viii Ides Aprilis DVI AUC ! 56 4 7 0.7 Ante diem vii Ides Aprilis DVI AUC ! 56 4 8 0.8 Ante diem vi Ides Aprilis DVI AUC ! 56 4 9 0.9 Ante diem v Ides Aprilis DVI AUC ! 56 4 10 0.0 Ante diem iv Ides Aprilis DVI AUC ! 56 4 11 0.0 Ante diem iii Ides Aprilis DVI AUC ! 56 4 12 0.0 Pridie Ides Aprilis DVI AUC ! 56 4 13 0.0 Ides Aprilis DVI AUC ! 56 4 14 0.0 Ante diem xvii Kalends Maius DVI AUC ! 56 4 15 0.0 Ante diem xvi Kalends Maius DVI AUC ! ... ! 56 4 28 0.0 Ante diem iv Kalends Maius DVI AUC ! 56 4 29 0.0 Ante diem iii Kalends Maius DVI AUC ! 56 4 30 0.0 Pridie Kalends Maius DVI AUC ! ! Discussion: ! ! "AUC" means "ab urbe condita", or "from the founding of the city". ! ! At the moment, we ignore F. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, character ( len = * ) S, a string representing the date. ! implicit none ! integer d integer d2 double precision f integer i_wrap integer iday integer ides integer ierror integer jday integer last character ( len = 10 ) lower integer m integer m2 integer m3 integer month_length_roman integer nones character ( len = * ) s character ( len = 10 ) s_day character ( len = 15 ) s_month character ( len = 15 ) s_month_next character ( len = 10 ) s_year integer y integer y2 logical year_is_leap_roman ! ! Copy the input. ! y2 = y m2 = m d2 = d ! ! Check the input. ! call ymd_check_roman ( y2, m2, d2, ierror ) if ( ierror /= 0 ) then s = '?' return end if call month_to_month_name_roman ( m2, s_month ) ! ! Get the next month's name. ! m3 = i_wrap ( m2+1, 1, 12 ) call month_to_month_name_roman ( m3, s_month_next ) call month_to_nones_roman ( m2, nones ) call month_to_ides_roman ( m2, ides ) last = month_length_roman ( y2, m2 ) if ( d2 == 1 ) then s = 'Kalends ' // s_month else if ( d2 < nones - 1 ) then jday = nones + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Nones ' // s_month else if ( d2 == nones - 1 ) then s = 'Pridie Nones ' // s_month else if ( d2 == nones ) then s = 'Nones ' // s_month else if ( d2 < ides - 1 ) then jday = ides + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Ides ' // s_month else if ( d2 == ides - 1 ) then s = 'Pridie Ides ' // s_month else if ( d2 == ides ) then s = 'Ides ' // s_month else if ( m2 == 2 .and. year_is_leap_roman ( y2 ) ) then if ( d2 < 25 ) then jday = last + 1 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( d2 == 25 ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem Bis ' // trim ( s_day ) // ' Kalends ' // s_month_next else if ( d2 < last ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s = 'Pridie Kalends ' // s_month_next end if else if ( d2 < last ) then jday = last + 2 - d2 call i_to_roman ( jday, s_day ) s_day = lower ( s_day ) s = 'Ante diem ' // trim ( s_day ) // ' Kalends ' // s_month_next else s = 'Pridie Kalends ' // s_month_next end if call i_to_roman ( y2, s_year ) call s_cat1 ( s, s_year, s ) call s_cat ( s, ' AUC', s ) return end subroutine ymdf_to_week_common ( y, m, d, f, iweek ) ! !******************************************************************************* ! !! YMDF_TO_WEEK_COMMON returns the week number for a Common YMDF date. ! ! ! Modified: ! ! 06 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, is the date. ! ! Output, integer IWEEK, is the week number of the date, with ! 1 for the first week, and 53 or 54 for the last. A week begins ! on Sunday. The first and last weeks may be partial weeks. ! implicit none ! integer d integer d1 integer d2 double precision days double precision f double precision f1 double precision f2 integer iday1 integer iday2 integer ierror integer iweek integer m integer m1 integer m2 integer ndays integer y integer y1 integer y2 ! ! Make a local copy of the input date. ! d2 = d m2 = m y2 = y f2 = f ! ! Check the input date. ! call ymdf_check_common ( y2, m2, d2, f2, ierror ) if ( ierror /= 0 ) then iweek = 0 return end if ! ! Find the number of days between Y/1/1 and Y/M1/D1. ! d1 = 1 m1 = 1 y1 = y f1 = 0.0D+00 call ymdf_dif_common ( y1, m1, d1, f1, y2, m2, d2, f2, days, ierror ) ! ! Find the day of the week of Y/1/1. ! call ymdf_to_weekday_common ( y1, m1, d1, f1, iday1 ) ! ! Find the day of the week of Y/M2/D2. ! call ymdf_to_weekday_common ( y2, m2, d2, f2, iday2 ) ! ! Expand the week containing Y/1/1 to begin on Sunday. ! ndays = int ( days ) + ( iday1 - 1 ) ! ! Expand the week containing Y/M2/D2 to end on Saturday. ! ndays = ndays + ( 8 - iday2 ) ! ! Now NDAYS should be an exact multiple of 7, and IWEEK is easy. ! iweek = ndays / 7 return end subroutine ymdf_to_weekday_common ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_COMMON returns the weekday of a Common YMDF date. ! ! ! Discussion: ! ! The "common" calendar is meant to be the calendar which is Julian up to ! day JED = 2299160, and Gregorian from day JED = 2299161 and after. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_common ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_english ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_ENGLISH returns the weekday of an English YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_english ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_gregorian ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_GREGORIAN returns the weekday of a Gregorian YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_gregorian ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_gregorian2 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_GREGORIAN2 returns the weekday of a Gregorian YMDF date. ! ! ! Discussion: ! ! This routine computes the day of the week from the date in ! the Gregorian calendar. ! ! Reference: ! ! E G Richards, ! Algorithm B, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 308. ! ! Modified: ! ! 16 March 2001 ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! implicit none ! integer c integer d double precision f integer i_modp integer i_wrap integer ierror integer m integer m_prime integer n integer p integer q integer t integer v integer w integer y integer y_prime integer z ! ! Check the input. ! call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then w = 0 return end if m_prime = mod ( 9 + m, 12 ) q = m_prime / 10 z = ( 13 * m_prime + 2 ) / 5 t = 28 * m_prime + z + d - 365 * q + 59 c = i_wrap ( t, 1, 7 ) y_prime = y - q v = ( y / 4 - y_prime / 4 ) - ( y / 100 - y_prime / 100 ) & + ( y / 400 - y_prime / 400 ) p = y + y / 4 - y / 100 + y / 400 - 1 - v n = 7 - i_modp ( p, 7 ) w = 1 + i_modp ( 7 + c - n, 7 ) return end subroutine ymdf_to_weekday_gregorian3 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_GREGORIAN3 returns the weekday of a Gregorian YMDF date. ! ! ! Discussion: ! ! The algorithm is also valid for BC years. ! ! Reference: ! ! E G Richards, ! Algorithm D, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 309. ! ! Modified: ! ! 16 March 2001 ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! implicit none ! integer d double precision f integer i_modp integer ierror integer m integer m_prime integer n integer w integer y integer y_prime integer y2 ! call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then w = 0 return end if if ( y < 0 ) then y2 = 1 - y else y2 = y end if m_prime = mod ( 9 + m, 12 ) y_prime = y2 - m_prime / 10 do while ( y_prime < 0 ) y_prime = y_prime + 400 end do w = 1 + i_modp ( 2 + d + ( 13 * m_prime + 2 ) / 5 & + y_prime + y_prime / 4 - y_prime / 100 + y_prime / 400, 7 ) return end subroutine ymdf_to_weekday_gregorian4 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_GREGORIAN4 returns the weekday of a Gregorian YMDF date. ! ! ! Discussion: ! ! This routine uses an algorithm by Zeller. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer a integer c integer d integer e double precision f integer i_modp integer ierror integer m integer u integer v integer w integer x integer y integer year integer z ! call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then w = 0 return end if if ( m <= 2 ) then a = m + 10 else a = m - 2 end if ! ! What do you want to happen when Y is negative? ! c = i_modp ( y, 100 ) e = ( y - c ) / 100 v = ( 13 * a - 1 ) / 5 x = c / 4 u = e / 4 z = v + x + u + d + c - 2 * e w = i_modp ( z, 7 ) + 1 return end subroutine ymdf_to_weekday_gregorian5 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_GREGORIAN5 returns the weekday of a Gregorian YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger, editor, ! CRC Standard Mathematical Tables and Formulae, ! CRC Press, 2000, page 738. ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer c integer d integer days double precision f integer i_modp integer ierror integer m integer mm integer w integer y integer yy ! call ymd_check_gregorian ( y, m, d, ierror ) if ( ierror /= 0 ) then w = 0 return end if c = ( y / 100 ) yy = y - c * 100 if ( m < 3 ) then mm = m + 10 yy = yy - 1 else mm = m - 2 end if days = d + int ( 2.6 * dble ( mm ) - 0.2 ) - 2 * c + yy + ( yy / 4 ) & + ( c / 4 ) w = i_modp ( days, 7 ) + 1 return end subroutine ymdf_to_weekday_hebrew ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_HEBREW returns the weekday of a Hebrew YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_hebrew ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_islamic_a ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_ISLAMIC_A returns the weekday of an Islamic A YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, is the week day number of the date, with ! 1 for Sunday, through 7 for Saturday. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_islamic_a ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_julian ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_JULIAN computes the weekday of a Julian YMDF date. ! ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! implicit none ! integer d double precision f double precision f2 double precision jed integer m integer w integer y ! call ymdf_to_jed_julian ( y, m, d, f, jed ) call jed_to_weekday ( jed, w, f2 ) return end subroutine ymdf_to_weekday_julian2 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_JULIAN2 returns the weekday of a Julian YMDF date. ! ! ! Discussion: ! ! This routine computes the day of the week from the date in ! the Julian calendar, that is, the calendar in force before the ! Gregorian calendar, in which every fourth year was a leap year. ! ! Reference: ! ! E G Richards, ! Algorithm A, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, pages 307-308. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! implicit none ! integer c integer d double precision f integer i_wrap integer m integer m_prime integer n integer p integer q integer t integer v integer w integer y integer y_prime integer z ! m_prime = mod ( 9 + m, 12 ) q = m_prime / 10 z = ( 13 * m_prime + 2 ) / 5 t = 28 * m_prime + z + d - 365 * q + 59 c = i_wrap ( t, 1, 7 ) y_prime = y - q v = y / 4 - y_prime / 4 p = y + y / 4 + 4 - v n = 7 - mod ( p, 7 ) w = i_wrap ( c + 1 - n, 1, 7 ) return end subroutine ymdf_to_weekday_julian3 ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_JULIAN3 returns the week day of a Julian YMD date. ! ! ! Discussion: ! ! The algorithm is also valid for BC years. ! ! Reference: ! ! E G Richards, ! Algorithm C, ! Mapping Time, The Calendar and Its History, ! Oxford, 1999, page 309. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! ! Output, integer W, the day of the week of the date. ! The days are numbered from Sunday through Saturday, 1 through 7. ! implicit none ! integer d double precision f integer m integer m_prime integer w integer y integer y2 integer y_prime ! if ( y < 0 ) then y2 = 1 - y else y2 = y end if m_prime = mod ( 9 + m, 12 ) y_prime = y2 - m_prime / 10 do while ( y_prime < 0 ) y_prime = y_prime + 28 end do w = 1 + mod ( d + ( 13 * m_prime + 2 ) / 5 + y_prime + y_prime / 4, 7 ) return end subroutine ymdf_to_weekday_republican ( y, m, d, f, w ) ! !******************************************************************************* ! !! YMDF_TO_WEEKDAY_REPUBLICAN returns the weekday of a Republican YMDF date. ! ! ! Discussion: ! ! The Republican calendar used a 10 day week. ! There was a final "month" of 5 or 6 days. ! ! Modified: ! ! 16 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer Y, integer M, integer D, double precision F, the YMDF date. ! !