program calpak_prb ! !******************************************************************************* ! !! CALPAK_PRB calls a series of tests for CALPAK. ! call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CALPAK_PRB' write ( *, '(a)' ) ' Tests for CALPAK.' write ( *, '(a)' ) ' ' call test0005 call test0006 call test001 call test002 call test003 call test004 call test005 call test006 call test0065 call test007 call test0075 call test008 call test009 call test010 call test011 call test012 call test0125 call test013 call test014 call test015 call test016 call test017 call test0175 call test018 call test019 call test020 call test165 call test17 call test175 call test18 call test185 call test19 call test195 call test20 call test21 call test215 call test22 call test23 call test24 call test25 call test255 call test26 call test265 call test27 call test275 call test28 call test29 call test30 call test31 call test315 call test32 call test325 call test326 call test327 call test328 call test33 call test335 call test336 call test337 call test34 call test344 call test345 call test35 call test36 call test365 call test37 call test373 call test375 call test376 call test38 call test389 call test39 call test394 call test395 call test40 call test41 call test415 call test42 call test43 call test435 call test44 call test45 call test46 call test47 call test48 call test49 call test495 call test50 call test501 call test502 call test503 call test51 call test515 call test5153 call test51535 call test5154 call test5155 call test5156 call test52 call test525 call test53 call test535 call test54 call test555 call test56 call test565 call test566 call test57 call test58 call test585 call test59 call test60 call test605 call test61 call test615 call test616 call test62 call test621 call test622 call test623 call test624 call test63 call test635 call test636 call test64 call test65 call test66 call test67 call test675 call test68 call test685 call test686 call test687 call test688 call test69 call test695 call test70 call test71 call test72 call test73 call test74 call test75 call test76 call test77 call test78 call test79 call test795 call test80 call test805 call test81 call test82 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CALPAK_PRB' write ( *, '(a)' ) ' Normal end of execution.' stop end subroutine test0005 ! !******************************************************************************* ! !! TEST0005 tests JED_TO_CWS_GPS. !! TEST0005 tests CWS_TO_JED_GPS. ! integer c2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 character ( len = 25 ) s2 double precision sec2 integer w2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0005' write ( *, '(a)' ) ' For the GPS calendar:' write ( *, '(a)' ) ' JED_TO_CWS_GPS: JED -> CWS.' write ( *, '(a)' ) ' CWS_TO_JED_GPS: CWS -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) CWS JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_gps ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_cws_gps ( jed1, c2, w2, sec2 ) call cws_to_s_gps ( c2, w2, sec2, s2 ) call cws_to_jed_gps ( c2, w2, sec2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test0006 ! !******************************************************************************* ! !! TEST0006 tests JED_TO_SS_UNIX. !! TEST0006 tests SS_TO_JED_UNIX. ! integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 double precision ss2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0006' write ( *, '(a)' ) ' For the UNIX SS calendar:' write ( *, '(a)' ) ' JED_TO_SS_UNIX: JED -> SS.' write ( *, '(a)' ) ' SS_TO_JED_UNIX: SS -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) SS JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_unix ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ss_unix ( jed1, ss2 ) call d_to_s_left ( ss2, s2 ) call ss_to_jed_unix ( ss2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test001 ! !******************************************************************************* ! !! TEST001 tests EASTER_DS. !! TEST001 tests EASTER_EGR. !! TEST001 tests EASTER_EGR2. !! TEST001 tests EASTER_KNUTH. !! TEST001 tests EASTER_STEWART. ! integer, parameter :: n_test = 10 ! integer d integer, dimension ( n_test ) :: d_test = & (/ 30, 12, 4, 23, 15, 31, 20, 11, 27, 16 /) integer i integer m integer, dimension ( n_test ) :: m_test = & (/ 3, 4, 4, 4, 4, 3, 4, 4, 3, 4 /) character ( len = 20 ) s integer y integer, dimension ( n_test ) :: y_test = & (/ 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST001' write ( *, '(a)' ) ' For the Gregorian calendar,' write ( *, '(a)' ) ' for a given year, compute the day and month of Easter.' write ( *, '(a)' ) ' EASTER_DS uses Duffett-Smith''s algorithm.' write ( *, '(a)' ) ' EASTER_EGR uses Richards''s algorithm.' write ( *, '(a)' ) ' EASTER_EGR2 uses Richards''s algorithm 2.' write ( *, '(a)' ) ' EASTER_KNUTH uses Knuth''s algorithm.' write ( *, '(a)' ) ' EASTER_STEWART uses Stewart''s algorithm.' do i = 1, n_test y = y_test(i) m = m_test(i) d = d_test(i) write ( *, '(a)' ) ' ' call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' CORRECT: ' // trim ( s ) call easter_ds ( y, m, d ) call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_DS: ' // trim ( s ) call easter_egr ( y, m, d ) call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_EGR: ' // trim ( s ) call easter_egr2 ( y, m, d ) call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_EGR2: ' // trim ( s ) call easter_knuth ( y, m, d ) call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_KNUTH: ' // trim ( s ) call easter_stewart ( y, m, d ) call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_STEWART: ' // trim ( s ) end do return end subroutine test002 ! !******************************************************************************* ! !! TEST002 tests EASTER_JULIAN. !! TEST002 tests EASTER_JULIAN2. ! integer, parameter :: n_test = 10 ! integer d integer, dimension ( n_test ) :: d_test = & (/ 27, 19, 11, 30, 15, 5, 27, 11, 1, 23 /) double precision f integer i double precision jed integer m integer, dimension ( n_test ) :: m_test = & (/ 4, 4, 4, 4, 4, 5, 4, 4, 5, 4 /) character ( len = 20 ) s integer y integer, dimension ( n_test ) :: y_test = & (/ 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST002' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' for a given year, compute the day and month of Easter.' write ( *, '(a)' ) ' EASTER_JULIAN uses Richard''s algorithm.' write ( *, '(a)' ) ' EASTER_JULIAN2 uses Richards''s algorithm.' do i = 1, n_test y = y_test(i) m = m_test(i) d = d_test(i) f = 0.5D+00 write ( *, '(a)' ) ' ' call ymd_to_s_gregorian ( y, m, d, s ) write ( *, '(a)' ) ' CORRECT (Gregorian): ' // trim ( s ) call ymdf_to_jed_gregorian ( y, m, d, f, jed ) call jed_to_ymdf_julian ( jed, y, m, d, f ) call ymdf_to_s_julian ( y, m, d, f, s ) write ( *, '(a)' ) ' CORRECT (Julian): ' // trim ( s ) call easter_julian ( y, m, d ) call ymd_to_s_julian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_JULIAN: ' // trim ( s ) call easter_julian2 ( y, m, d ) call ymd_to_s_julian ( y, m, d, s ) write ( *, '(a)' ) ' EASTER_JULIAN2: ' // trim ( s ) end do return end subroutine test003 ! !******************************************************************************* ! !! TEST003 tests JED_TO_MAYAN_LONG. !! TEST003 tests MAYAN_LONG_TO_JED. ! integer baktun double precision f integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer katun integer kin integer pictun integer tun integer uinal ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST003' write ( *, '(a)' ) ' For converting between Julian Ephemeris Dates' write ( *, '(a)' ) ' and Mayan Long Count dates:' write ( *, '(a)' ) ' JED_TO_MAYAN_LONG,' write ( *, '(a)' ) ' MAYAN_LONG_TO_JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) MAYAN JED (out)' write ( *, '(a)' ) ' P B K T U D' write ( *, '(a)' ) ' ' call epoch_to_jed_mayan_long ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_mayan_long ( jed1, pictun, baktun, katun, tun, uinal, kin, f ) call mayan_long_to_jed ( pictun, baktun, katun, tun, uinal, kin, f, jed3 ) write ( *, '(f11.2,5x,6i4,5x,f11.2)' ) jed1, pictun, baktun, katun, tun, & uinal, kin, jed3 end if end do return end subroutine test004 ! !******************************************************************************* ! !! TEST004 tests JED_TO_MAYAN_ROUND. !! TEST004 tests MAYAN_ROUND_TO_JED. ! integer a2 integer b2 integer c2 integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST004' write ( *, '(a)' ) ' For converting between Julian Ephemeris Dates' write ( *, '(a)' ) ' and Mayan Round dates:' write ( *, '(a)' ) ' JED_TO_MAYAN_ROUND,' write ( *, '(a)' ) ' MAYAN_ROUND_TO_JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) MAYAN JED (out)' write ( *, '(a)' ) ' Y A B C D F' write ( *, '(a)' ) ' ' call epoch_to_jed_mayan_long ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_mayan_round ( jed1, y2, a2, b2, c2, d2, f2 ) call mayan_round_to_jed ( y2, a2, b2, c2, d2, f2, jed3 ) write ( *, '(f11.2,5x,5i4,f5.2,5x,f11.2)' ) & jed1, y2, a2, b2, c2, d2, f2, jed3 end if end do return end subroutine test005 ! !******************************************************************************* ! !! TEST005 tests JED_TO_WEEKDAY. ! integer i double precision f2 double precision jed1 character ( len = 15 ) s2 integer w2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST005' write ( *, '(a)' ) ' JED_TO_WEEKDAY reports the day of the week' write ( *, '(a)' ) ' for a Julian Ephemeris Date.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED W Name' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_weekday ( jed1, w2, f2 ) call weekday_to_name_common ( w2, s2 ) write ( *, '(f11.2,2x,i1,2x,a)' ) jed1, w2, s2 end do return end subroutine test006 ! !******************************************************************************* ! !! TEST006 tests JED_TO_YEAR_HEBREW. ! integer i integer ierror double precision jed_epoch double precision jed1 character ( len = 10 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST006' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' JED_TO_YEAR_HEBREW returns the year of a given JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED Hebrew Year' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_year_hebrew ( jed1, y2 ) call y_to_s_hebrew ( y2, s2 ) write ( *, '(f11.2,5x,a)' ) jed1, s2 end if end do return end subroutine test0065 ! !******************************************************************************* ! !! TEST0065 tests JED_TO_YEARCOUNT_BESSEL. !! TEST0065 tests JED_TO_YEARCOUNT_JULIAN. ! double precision bessel integer d double precision f integer i double precision jed double precision julian integer m character ( len = 25 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0065' write ( *, '(a)' ) ' JED_TO_YEARCOUNT_BESSEL' write ( *, '(a)' ) ' returns a tropical year count based at 1900.' write ( *, '(a)' ) ' JED_TO_YEARCOUNT_JULIAN' write ( *, '(a)' ) ' returns a Julian year count based at 2000.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Common Bessel Year Julian Year' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_common ( jed, y, m, d, f ) call ymdf_to_s_common ( y, m, d, f, s ) call jed_to_yearcount_bessel ( jed, bessel ) call jed_to_yearcount_julian ( jed, julian ) write ( *, '(f11.2,5x,a20,2x,2f12.4)' ) jed, s, bessel, julian end do return end subroutine test007 ! !******************************************************************************* ! !! TEST007 tests JED_TO_YJF_COMMON. !! TEST007 tests YJF_TO_JED_COMMON. ! double precision f2 integer i integer ierror integer j2 double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST007' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' JED_TO_YJF_COMMON: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_COMMON: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_yjf_common ( jed1, y2, j2, f2 ) call yjf_to_s_common ( y2, j2, f2, s2 ) call yjf_to_jed_common ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test0075 ! !******************************************************************************* ! !! TEST0075 tests JED_TO_MJD. !! TEST0075 tests MJD_TO_JED. ! integer i double precision jed1 double precision mjd2 double precision jed3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0075' write ( *, '(a)' ) ' For the modified JED:' write ( *, '(a)' ) ' JED_TO_MJD: JED -> MJD.' write ( *, '(a)' ) ' MJD_TO_JED: MJD -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) JEDMOD JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_mjd ( jed1, mjd2 ) call mjd_to_jed ( mjd2, jed3 ) write ( *, '(f11.2,5x,f11.2,5x,f11.2)' ) jed1, mjd2, jed3 end do return end subroutine test008 ! !******************************************************************************* ! !! TEST008 tests JED_TO_YJF_ENGLISH. !! TEST008 tests YJF_TO_JED_ENGLISH. ! double precision f2 integer i integer ierror integer j2 double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST008' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' JED_TO_YJF_ENGLISH: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_ENGLISH: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_english ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch )then call jed_to_yjf_english ( jed1, y2, j2, f2 ) call yjf_to_s_english ( y2, j2, f2, s2 ) call yjf_to_jed_english ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test009 ! !******************************************************************************* ! !! TEST009 tests JED_TO_YJF_GREGORIAN. !! TEST009 tests YJF_TO_JED_GREGORIAN. ! double precision f2 integer i integer ierror integer j2 double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST009' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' JED_TO_YJF_GREGORIAN: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_GREGORIAN: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_gregorian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch )then call jed_to_yjf_gregorian ( jed1, y2, j2, f2 ) call yjf_to_s_gregorian ( y2, j2, f2, s2 ) call yjf_to_jed_gregorian ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test010 ! !******************************************************************************* ! !! TEST010 tests JED_TO_YJF_HEBREW. !! TEST010 tests YJF_TO_JED_HEBREW. ! double precision f2 integer i integer ierror integer j2 double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST010' write ( *, '(a)' ) ' For the Hebrew calendar:' write ( *, '(a)' ) ' JED_TO_YJF_HEBREW: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_HEBREW: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch )then call jed_to_yjf_hebrew ( jed1, y2, j2, f2 ) call yjf_to_s_hebrew ( y2, j2, f2, s2 ) call yjf_to_jed_hebrew ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test011 ! !******************************************************************************* ! !! TEST011 tests JED_TO_YJF_REPUBLICAN. !! TEST011 tests YJF_TO_JED_REPUBLICAN. ! double precision f2 integer i integer ierror integer j2 double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST011' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' JED_TO_YJF_REPUBLICAN: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_REPUBLICAN: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)') ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_republican ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch )then call jed_to_yjf_republican ( jed1, y2, j2, f2 ) call yjf_to_s_republican ( y2, j2, f2, s2 ) call yjf_to_jed_republican ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test012 ! !******************************************************************************* ! !! TEST012 tests JED_TO_YJF_ROMAN. !! TEST012 tests YJF_TO_JED_ROMAN. ! double precision f2 integer i integer ierror integer j2 double precision jed_epoch double precision jed1 double precision jed3 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST012' write ( *, '(a)' ) ' For the Roman calendar:' write ( *, '(a)' ) ' JED_TO_YJF_ROMAN: JED -> YJF.' write ( *, '(a)' ) ' YJF_TO_JED_ROMAN: YJF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YJF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_roman ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch )then call jed_to_yjf_roman ( jed1, y2, j2, f2 ) call yjf_to_s_roman ( y2, j2, f2, s2 ) call yjf_to_jed_roman ( y2, j2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test0125 ! !******************************************************************************* ! !! TEST0125 tests JED_TO_YMDF_ALEXANDRIAN. !! TEST0125 tests YMDF_TO_JED_ALEXANDRIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 25 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0125' write ( *, '(a)' ) ' For the Alexandrian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ALEXANDRIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ALEXANDRIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_alexandrian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_alexandrian ( jed1, y2, m2, d2, f2 ) call ymd_to_s_alexandrian ( y2, m2, d2, s2 ) call ymdf_to_jed_alexandrian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test013 ! !******************************************************************************* ! !! TEST013 tests JED_TO_YMDF_ARMENIAN. !! TEST013 tests YMDF_TO_JED_ARMENIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST013' write ( *, '(a)' ) ' For the Armenian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ARMENIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ARMENIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_armenian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_armenian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_armenian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test014 ! !******************************************************************************* ! !! TEST014 tests JED_TO_YMDF_BAHAI. !! TEST014 tests YMDF_TO_JED_BAHAI. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST014' write ( *, '(a)' ) ' For the Bahai calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_BAHAI: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_BAHAI: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_bahai ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_bahai ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_bahai ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test015 ! !******************************************************************************* ! !! TEST015 tests JED_TO_YMDF_COMMON. !! TEST015 tests YMDF_TO_JED_COMMON. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST015' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_COMMON: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_COMMON: YMDF -> JED' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_common ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_common ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_common ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test016 ! !******************************************************************************* ! !! TEST016 tests JED_TO_YMDF_COPTIC. !! TEST016 tests YMDF_TO_JED_COPTIC. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST016' write ( *, '(a)' ) ' For the Coptic calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_COPTIC: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_COPTIC: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_coptic ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_coptic ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_coptic ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test017 ! !******************************************************************************* ! !! TEST017 tests JED_TO_YMDF_EG_CIVIL. !! TEST017 tests YMDF_TO_JED_EG_CIVIL. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 25 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST017' write ( *, '(a)' ) ' For the Egyptian Civil calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_EG_CIVIL: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_EG_CIVIL: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_eg_civil ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_eg_civil ( jed1, y2, m2, d2, f2 ) call ymd_to_s_eg_civil ( y2, m2, d2, s2 ) call ymdf_to_jed_eg_civil ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test0175 ! !******************************************************************************* ! !! TEST0175 tests JED_TO_YMDF_EG_LUNAR. !! TEST0175 tests YMDF_TO_JED_EG_LUNAR. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 25 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0175' write ( *, '(a)' ) ' For the Egyptian Lunar calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_EG_LUNAR: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_EG_LUNAR: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_eg_lunar ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_eg_lunar ( jed1, y2, m2, d2, f2 ) call ymd_to_s_eg_lunar ( y2, m2, d2, s2 ) call ymdf_to_jed_eg_lunar ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test018 ! !******************************************************************************* ! !! TEST018 tests JED_TO_YMDF_ENGLISH. !! TEST018 tests YMDF_TO_JED_ENGLISH. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST018' write ( *, '(a)' ) ' For the English calendar,' write ( *, '(a)' ) ' JED_TO_YMDF_ENGLISH: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ENGLISH: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_english ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_english ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_english ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test019 ! !******************************************************************************* ! !! TEST019 tests JED_TO_YMDF_ETHIOPIAN. !! TEST019 tests YMDF_TO_JED_ETHIOPIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST019' write ( *, '(a)' ) ' For the Ethiopian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ETHIOPIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ETHIOPIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_ethiopian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_ethiopian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_ethiopian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test020 ! !******************************************************************************* ! !! TEST020 tests JED_TO_YMDF_GREGORIAN. !! TEST020 tests YMDF_TO_JED_GREGORIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST020' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_GREGORIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_GREGORIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_gregorian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_gregorian ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_gregorian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test165 ! !******************************************************************************* ! !! TEST165 tests JED_TO_YMDF_GREGORIAN2. !! TEST165 tests YMDF_TO_JED_GREGORIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST165' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_GREGORIAN2: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_GREGORIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_gregorian2 ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_gregorian ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_gregorian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test17 ! !******************************************************************************* ! !! TEST17 tests JED_TO_YMDF_HEBREW. !! TEST17 tests YMDF_TO_JED_HEBREW. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST17' write ( *, '(a)' ) ' For the Hebrew calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_HEBREW: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_HEBREW: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_hebrew ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_hebrew ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_hebrew ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test175 ! !******************************************************************************* ! !! TEST175 tests JED_TO_YMDF_HINDU_SOLAR. !! TEST175 tests YMDF_TO_JED_HINDU_SOLAR. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST175' write ( *, '(a)' ) ' For the Hindu Solar calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_HINDU_SOLAR: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_HINDU_SOLAR: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_hindu_solar ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_hindu_solar ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_hindu_solar ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test18 ! !******************************************************************************* ! !! TEST18 tests JED_TO_YMDF_ISLAMIC_A. !! TEST18 tests YMDF_TO_JED_ISLAMIC_A. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST18' write ( *, '(a)' ) ' For the Islamic A calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ISLAMIC_A: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ISLAMIC_A: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_islamic_a ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_islamic_a ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_islamic ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_islamic_a ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test185 ! !******************************************************************************* ! !! TEST185 tests JED_TO_YMDF_ISLAMIC_A. !! TEST185 tests YMDF_TO_JED_ISLAMIC_A2. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST185' write ( *, '(a)' ) ' For the Islamic A calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ISLAMIC_A: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ISLAMIC_A2: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_islamic_a ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_islamic_a ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_islamic ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_islamic_a2 ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test19 ! !******************************************************************************* ! !! TEST19 tests JED_TO_YMDF_ISLAMIC_B. !! TEST19 tests YMDF_TO_JED_ISLAMIC_B. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST19' write ( *, '(a)' ) ' For the Islamic B calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ISLAMIC_B: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ISLAMIC_B: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_islamic_b ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_islamic_b ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_islamic ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_islamic_b ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test195 ! !******************************************************************************* ! !! TEST195 tests JED_TO_YMDF_JELALI. !! TEST195 tests YMDF_TO_JED_JELALI. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST195' write ( *, '(a)' ) ' For the Jelali calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_JELALI: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_JELALI: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_jelali ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 < jed_epoch ) then cycle end if call jed_to_ymdf_jelali ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_jelali ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test20 ! !******************************************************************************* ! !! TEST20 tests JED_TO_YMDF_JULIAN. !! TEST20 tests YMDF_TO_JED_JULIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST20' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_JULIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_JULIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_julian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_julian ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_julian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test21 ! !******************************************************************************* ! !! TEST21 tests JED_TO_YMDF_JULIAN2. !! TEST21 tests YMDF_TO_JED_JULIAN2. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST21' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_JULIAN2: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_JULIAN2: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_julian2 ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_julian ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_julian2 ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test215 ! !******************************************************************************* ! !! TEST215 tests JED_TO_YMDF_JULIAN3. !! TEST215 tests YMDF_TO_JED_JULIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST215' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_JULIAN3: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_JULIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if call jed_to_ymdf_julian3 ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_julian ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_julian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end do return end subroutine test22 ! !******************************************************************************* ! !! TEST22 tests JED_TO_YMDF_KHWARIZMIAN. !! TEST22 tests YMDF_TO_JED_KHWARIZMIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST22' write ( *, '(a)' ) ' For the Khwarizmian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_KHWARIZMIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_KHWARIZMIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_khwarizmian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_khwarizmian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_khwarizmian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test23 ! !******************************************************************************* ! !! TEST23 tests JED_TO_YMDF_MACEDONIAN. !! TEST23 tests YMDF_TO_JED_MACEDONIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST23' write ( *, '(a)' ) ' For the Macedonian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_MACEDONIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_MACEDONIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_macedonian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_macedonian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_macedonian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test24 ! !******************************************************************************* ! !! TEST24 tests JED_TO_YMDF_PERSIAN. !! TEST24 tests YMDF_TO_JED_PERSIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST24' write ( *, '(a)' ) ' For the Persian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_PERSIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_PERSIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_persian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_persian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_persian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test25 ! !******************************************************************************* ! !! TEST25 tests JED_TO_YMDF_REPUBLICAN. !! TEST25 tests YMDF_TO_JED_REPUBLICAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST25' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_REPUBLICAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_REPUBLICAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_republican ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_republican ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_republican ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_republican ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test255 ! !******************************************************************************* ! !! TEST255 tests JED_TO_YMDF_ROMAN. !! TEST255 tests YMDF_TO_JED_ROMAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 45 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST255' write ( *, '(a)' ) ' For the Roman calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ROMAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ROMAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_roman ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_roman ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_roman ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_roman ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test26 ! !******************************************************************************* ! !! TEST26 tests JED_TO_YMDF_SAKA. !! TEST26 tests YMDF_TO_JED_SAKA. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST26' write ( *, '(a)' ) ' For the Saka calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_SAKA: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_SAKA: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_saka ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_saka ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_saka ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test265 ! !******************************************************************************* ! !! TEST265 tests JED_TO_YMDF_SOOR_SAN. !! TEST265 tests YMDF_TO_JED_SOOR_SAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST265' write ( *, '(a)' ) ' For the Soor San calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_SOOR_SAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_SOOR_SAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_soor_san ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_soor_san ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_soor_san ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test27 ! !******************************************************************************* ! !! TEST27 tests JED_TO_YMDF_SYRIAN. !! TEST27 tests YMDF_TO_JED_SYRIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST27' write ( *, '(a)' ) ' For the Syrian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_SYRIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_SYRIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_syrian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_syrian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_syrian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test275 ! !******************************************************************************* ! !! TEST275 tests JED_TO_YMDF_ZOROASTRIAN. !! TEST275 tests YMDF_TO_JED_ZOROASTRIAN. ! integer d2 double precision f2 integer i integer ierror double precision jed_epoch double precision jed1 double precision jed3 integer m2 character ( len = 20 ) s2 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST275' write ( *, '(a)' ) ' For the Zoroastrian calendar:' write ( *, '(a)' ) ' JED_TO_YMDF_ZOROASTRIAN: JED -> YMDF.' write ( *, '(a)' ) ' YMDF_TO_JED_ZOROASTRIAN: YMDF -> JED.' write ( *, '(a)' ) ' ' write ( *, '(a)') ' JED (in) YMDF JED (out)' write ( *, '(a)' ) ' ' call epoch_to_jed_zoroastrian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_zoroastrian ( jed1, y2, m2, d2, f2 ) call ymdf_to_s_numeric ( y2, m2, d2, f2, s2 ) call ymdf_to_jed_zoroastrian ( y2, m2, d2, f2, jed3 ) write ( *, '(f11.2,5x,a,5x,f11.2)' ) jed1, s2, jed3 end if end do return end subroutine test28 ! !******************************************************************************* ! !! TEST28 tests MONTH_CAL_COMMON. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST28' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' MONTH_CAL_COMMON prints a month calendar.' write ( *, '(a)' ) ' ' y = 1582 m = 10 call month_cal_common ( y, m ) y = 1752 m = 9 call month_cal_common ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_common ( jed, y, m, d, f ) call month_cal_common ( y, m ) return end subroutine test29 ! !******************************************************************************* ! !! TEST29 tests MONTH_CAL_ENGLISH. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST29' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' MONTH_CAL_ENGLISH prints a month calendar.' write ( *, '(a)' ) ' ' y = 1582 m = 10 call month_cal_english ( y, m ) y = 1752 m = 9 call month_cal_english ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_english ( jed, y, m, d, f ) call month_cal_english ( y, m ) return end subroutine test30 ! !******************************************************************************* ! !! TEST30 tests MONTH_CAL_GREGORIAN. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST30' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' MONTH_CAL_GREGORIAN prints a month calendar.' write ( *, '(a)' ) ' ' y = 1582 m = 10 call month_cal_gregorian ( y, m ) y = 1752 m = 9 call month_cal_gregorian ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_gregorian ( jed, y, m, d, f ) call month_cal_gregorian ( y, m ) return end subroutine test31 ! !******************************************************************************* ! !! TEST31 tests MONTH_CAL_HEBREW. ! integer d integer d2 double precision f double precision f2 double precision jed integer m integer m2 integer y integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST31' write ( *, '(a)' ) ' For the Hebrew calendar:' write ( *, '(a)' ) ' MONTH_CAL_HEBREW prints a month calendar.' write ( *, '(a)' ) ' ' y = 1582 m = 10 d = 1 f = 0.5D+00 call ymdf_to_jed_common ( y, m, d, f, jed ) call jed_to_ymdf_hebrew ( jed, y2, m2, d2, f2 ) call month_cal_hebrew ( y2, m2 ) y = 1752 m = 9 d = 1 f = 0.5D+00 call ymdf_to_jed_common ( y, m, d, f, jed ) call jed_to_ymdf_hebrew ( jed, y2, m2, d2, f2 ) call month_cal_hebrew ( y2, m2 ) call now_to_jed ( jed ) call jed_to_ymdf_hebrew ( jed, y2, m2, d2, f2 ) call month_cal_hebrew ( y2, m2 ) return end subroutine test315 ! !******************************************************************************* ! !! TEST315 tests MONTH_CAL_ISLAMIC_A. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST315' write ( *, '(a)' ) ' For the Islamic A calendar:' write ( *, '(a)' ) ' MONTH_CAL_ISLAMIC_A prints a month calendar.' write ( *, '(a)' ) ' ' y = 500 m = 1 call month_cal_islamic_a ( y, m ) y = 500 m = 2 call month_cal_islamic_a ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_islamic_a ( jed, y, m, d, f ) call month_cal_islamic_a ( y, m ) return end subroutine test32 ! !******************************************************************************* ! !! TEST32 tests MONTH_CAL_JULIAN. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST32' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' MONTH_CAL_JULIAN prints a month calendar.' write ( *, '(a)' ) ' ' y = 1582 m = 10 call month_cal_julian ( y, m ) y = 1752 m = 9 call month_cal_julian ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_julian ( jed, y, m, d, f ) call month_cal_julian ( y, m ) return end subroutine test325 ! !******************************************************************************* ! !! TEST325 tests MONTH_CAL_REPUBLICAN. ! integer d double precision f double precision jed integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST325' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' MONTH_CAL_REPUBLICAN prints a month calendar.' write ( *, '(a)' ) ' ' y = 3 m = 12 call month_cal_republican ( y, m ) y = 3 m = 13 call month_cal_republican ( y, m ) call now_to_jed ( jed ) call jed_to_ymdf_republican ( jed, y, m, d, f ) call month_cal_republican ( y, m ) return end subroutine test326 ! !******************************************************************************* ! !! TEST326 tests MONTH_CAL_ROMAN. ! integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST326' write ( *, '(a)' ) ' For the Roman calendar:' write ( *, '(a)' ) ' MONTH_CAL_ROMAN prints a month calendar.' y = 100 m = 12 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Year = ', y write ( *, '(a,i6)' ) ' Month = ', m call month_cal_roman ( y, m ) y = 256 m = 2 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Year = ', y write ( *, '(a,i6)' ) ' Month = ', m call month_cal_roman ( y, m ) return end subroutine test327 ! !******************************************************************************* ! !! TEST327 tests MONTH_CAL_STORE_COMMON. ! integer i character ( len = 20 ) lines(6) integer m integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST327' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' MONTH_CAL_STORE_COMMON writes the day numbers for' write ( *, '(a)' ) ' a monthly calendar into a data structure.' y = 1984 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Calendar:' write ( *, '(a,i6)' ) ' Year = ', y do m = 1, 12 call month_cal_store_common ( y, m, lines ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Month = ', m write ( *, '(a)' ) ' ' do i = 1, 6 write ( *, '(i1,4x,a)' ) i, lines(i) end do end do return end subroutine test328 ! !******************************************************************************* ! !! TEST328 tests MONTH_LENGTH_BAHAI. ! integer, parameter :: n_test = 1 ! integer days integer i_test integer m integer month_length_bahai character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_bahai integer year_length_months_bahai ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST328' write ( *, '(a)' ) ' For the Bahai calendar:' write ( *, '(a)' ) ' MONTH_LENGTH_BAHAI returns month lengths.' y_test(1) = 60 do i_test = 1, n_test y = y_test(i_test) call y_to_s_bahai ( y, sy ) months = year_length_months_bahai ( y ) days = year_length_bahai ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_bahai ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_bahai ( y, m ) end do end do return end subroutine test33 ! !******************************************************************************* ! !! TEST33 tests MONTH_LENGTH_COMMON. ! integer, parameter :: n_test = 4 ! integer days integer i_test integer m integer month_length_common character ( len = 10 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_common integer year_length_months_common ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST33' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' MONTH_LENGTH_COMMON returns month lengths.' y_test(1) = 1582 y_test(2) = 1752 y_test(3) = 1900 y_test(4) = 2000 do i_test = 1, n_test y = y_test(i_test) call y_to_s_common ( y, sy ) months = year_length_months_common ( y ) days = year_length_common ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_common ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_common ( y, m ) end do end do return end subroutine test335 ! !******************************************************************************* ! !! TEST335 tests MONTH_LENGTH_COPTIC. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_coptic character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_coptic integer year_length_months_coptic ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST335' write ( *, '(a)' ) ' For the Coptic calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_COPTIC returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_coptic ( y, sy ) months = year_length_months_coptic ( y ) days = year_length_coptic ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_coptic ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_coptic ( y, m ) end do end do return end subroutine test336 ! !******************************************************************************* ! !! TEST336 tests MONTH_LENGTH_EG_CIVIL. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_eg_civil character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_eg_civil integer year_length_months_eg_civil ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST336' write ( *, '(a)' ) ' For the Egyptian Civil calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_EG_CIVIL returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_eg_civil ( y, sy ) months = year_length_months_eg_civil ( y ) days = year_length_eg_civil ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_eg_civil ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_eg_civil ( y, m ) end do end do return end subroutine test337 ! !******************************************************************************* ! !! TEST337 tests MONTH_EG_LUNAR. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_eg_lunar character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_eg_lunar integer year_length_months_eg_lunar ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST337' write ( *, '(a)' ) ' For the Egyptian Lunar calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_EG_LUNAR returns month lengths.' y_test(1) = 1 y_test(2) = 2 do i_test = 1, n_test y = y_test(i_test) call y_to_s_eg_lunar ( y, sy ) months = year_length_months_eg_lunar ( y ) days = year_length_eg_lunar ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_eg_lunar ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_eg_lunar ( y, m ) end do end do return end subroutine test34 ! !******************************************************************************* ! !! TEST34 tests MONTH_LENGTH_ENGLISH. ! integer, parameter :: n_test = 4 ! integer days integer i_test integer m integer month_length_english character ( len = 10 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_english integer year_length_months_english ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST34' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' MONTH_LENGTH_ENGLISH returns month lengths.' y_test(1) = 1582 y_test(2) = 1752 y_test(3) = 1900 y_test(4) = 2000 do i_test = 1, n_test y = y_test(i_test) call y_to_s_english ( y, sy ) months = year_length_months_english ( y ) days = year_length_english ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_common ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_english ( y, m ) end do end do return end subroutine test344 ! !******************************************************************************* ! !! TEST344 tests MONTH_LENGTH_ETHIOPIAN. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_ethiopian character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_ethiopian integer year_length_months_ethiopian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST344' write ( *, '(a)' ) ' For the Ethiopian calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_ETHIOPIAN returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_ethiopian ( y, sy ) months = year_length_months_ethiopian ( y ) days = year_length_ethiopian ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_ethiopian ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_ethiopian ( y, m ) end do end do return end subroutine test345 ! !******************************************************************************* ! !! TEST345 tests MONTH_LENGTH_GREEK. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_greek character ( len = 15 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_greek integer year_length_months_greek ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST345' write ( *, '(a)' ) ' For the Greek calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_GREEK returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_greek ( y, sy ) months = year_length_months_greek ( y ) days = year_length_greek ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_greek ( y, m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_greek ( y, m ) end do end do return end subroutine test35 ! !******************************************************************************* ! !! TEST35 tests MONTH_LENGTH_GREGORIAN. ! integer, parameter :: n_test = 4 ! integer days integer i_test integer m integer month_length_gregorian character ( len = 10 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_gregorian integer year_length_months_gregorian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST35' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' MONTH_LENGTH_GREGORIAN returns month lengths.' y_test(1) = 1582 y_test(2) = 1752 y_test(3) = 1900 y_test(4) = 2000 do i_test = 1, n_test y = y_test(i_test) call y_to_s_gregorian ( y, sy ) months = year_length_months_gregorian ( y ) days = year_length_gregorian ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_common ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_gregorian ( y, m ) end do end do return end subroutine test36 ! !******************************************************************************* ! !! TEST36 tests MONTH_LENGTH_HEBREW. ! integer, parameter :: n_test = 3 ! integer days integer i_test integer m integer month_length_hebrew character ( len = 10 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_hebrew integer year_length_months_hebrew ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST36' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_HEBREW returns month lengths.' y_test(1) = 5760 y_test(2) = 5762 y_test(3) = 5765 do i_test = 1, n_test y = y_test(i_test) call y_to_s_hebrew ( y, sy ) months = year_length_months_hebrew ( y ) days = year_length_hebrew ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_hebrew ( y, m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_hebrew ( y, m ) end do end do return end subroutine test365 ! !******************************************************************************* ! !! TEST365 tests MONTH_LENGTH_ISLAMIC. ! integer, parameter :: n_test = 3 ! integer days integer i_test integer m integer month_length_islamic character ( len = 10 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_islamic integer year_length_months_islamic ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST365' write ( *, '(a)' ) ' For the Islamic calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_ISLAMIC returns month lengths.' y_test(1) = 500 y_test(2) = 501 y_test(3) = 502 do i_test = 1, n_test y = y_test(i_test) call y_to_s_islamic ( y, sy ) months = year_length_months_islamic ( y ) days = year_length_islamic ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_islamic ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_islamic ( y, m ) end do end do return end subroutine test37 ! !******************************************************************************* ! !! TEST37 tests MONTH_LENGTH_JULIAN. ! integer, parameter :: n_test = 4 ! integer days integer i_test integer m integer month_length_julian character ( len = 10 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_julian integer year_length_months_julian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST37' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_JULIAN returns month lengths.' y_test(1) = 1582 y_test(2) = 1752 y_test(3) = 1900 y_test(4) = 2000 do i_test = 1, n_test y = y_test(i_test) call y_to_s_julian ( y, sy ) months = year_length_months_julian ( y ) days = year_length_julian ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_common ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_julian ( y, m ) end do end do return end subroutine test373 ! !******************************************************************************* ! !! TEST373 tests MONTH_LENGTH_PERSIAN. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_persian character ( len = 15 ) month_name integer months character ( len = 15 ) sy integer y integer y_test(n_test) integer year_length_persian integer year_length_months_persian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST373' write ( *, '(a)' ) ' For the Persian calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_PERSIAN returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_persian ( y, sy ) months = year_length_months_persian ( y ) days = year_length_persian ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_persian ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_persian ( y, m ) end do end do return end subroutine test375 ! !******************************************************************************* ! !! TEST375 tests MONTH_LENGTH_REPUBLICAN. ! integer, parameter :: n_test = 1 ! integer days integer i_test integer m integer month_length_republican character ( len = 15 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_months_republican integer year_length_republican ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST375' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' MONTH_LENGTH_REPUBLICAN returns month lengths.' y_test(1) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_republican ( y, sy ) months = year_length_months_republican ( y ) days = year_length_republican ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_republican ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_republican ( y, m ) end do end do return end subroutine test376 ! !******************************************************************************* ! !! TEST376 tests MONTH_LENGTH_ROMAN. ! integer, parameter :: n_test = 2 ! integer days integer i_test integer m integer month_length_roman character ( len = 15 ) month_name integer months character ( len = 10 ) sy integer y integer y_test(n_test) integer year_length_months_roman integer year_length_roman ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST376' write ( *, '(a)' ) ' For the Roman calendar,' write ( *, '(a)' ) ' MONTH_LENGTH_ROMAN returns month lengths.' y_test(1) = 3 y_test(2) = 4 do i_test = 1, n_test y = y_test(i_test) call y_to_s_roman ( y, sy ) months = year_length_months_roman ( y ) days = year_length_roman ( y ) write ( *, '(a)' ) ' ' write ( *, '(2x,i6)' ) y write ( *, '(2x,a)' ) trim ( sy ) write ( *, '(a,i6)' ) ' Year length in months = ', months write ( *, '(a,i6)' ) ' Year length in days = ', days write ( *, '(a)' ) ' ' do m = 1, months call month_to_month_name_roman ( m, month_name ) write ( *, '(6x,a,2x,i4)' ) month_name, month_length_roman ( y, m ) end do end do return end subroutine test38 ! !******************************************************************************* ! !! TEST38 tests MONTH_NAME_TO_MONTH_COMMON ! integer, parameter :: ntest = 9 ! integer i integer m character ( len = 10 ) month_name character ( len = 10 ) test(ntest) ! test(1) = 'J' test(2) = 'Febooary' test(3) = 'Dec.' test(4) = 'April' test(5) = 'Aug' test(6) = 'Mar' test(7) = 'May' test(8) = 'o' test(9) = 'nO' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST38' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' MONTH_NAME_TO_MONTH_COMMON identifies month names:' write ( *, '(a)' ) ' ' do i = 1, ntest call month_name_to_month_common ( test(i), m ) call month_to_month_name_common ( m, month_name ) write ( *, '(2x,a3,2x,i2,2x,a9)' ) test(i), m, month_name end do return end subroutine test389 ! !******************************************************************************* ! !! TEST389 tests MONTH_TO_MONTH_NAME_BAHAI. ! integer i integer m character ( len = 15 ) month_name integer months integer y integer year_length_months_bahai ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST389' write ( *, '(a)' ) ' For the Bahai calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_BAHAI names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_bahai ( y ) do m = 1, months call month_to_month_name_bahai ( m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test39 ! !******************************************************************************* ! !! TEST39 tests MONTH_TO_MONTH_NAME_COMMON. ! integer i integer m character ( len = 10 ) month_name integer months integer y integer year_length_months_common ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST39' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_COMMON names the months:' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_common ( y ) do m = 1, months call month_to_month_name_common ( m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test394 ! !******************************************************************************* ! !! TEST394 tests MONTH_TO_MONTH_NAME_EG_CIVIL. ! integer i integer m character ( len = 15 ) month_name integer months integer y integer year_length_months_eg_civil ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST394' write ( *, '(a)' ) ' For the Egyptian Civil calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_EG_CIVIL names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_eg_civil ( y ) do m = 1, months call month_to_month_name_eg_civil ( m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test395 ! !******************************************************************************* ! !! TEST395 tests MONTH_TO_MONTH_NAME_GREEK. ! integer i integer j integer m character ( len = 15 ) month_name integer months integer y integer year_length_months_greek ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST395' write ( *, '(a)' ) ' For the Greek calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_GREEK names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_greek ( y ) do i = 1, months m = i call month_to_month_name_greek ( y, m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test40 ! !******************************************************************************* ! !! TEST40 tests MONTH_TO_MONTH_NAME_HEBREW. ! integer i integer j integer m character ( len = 10 ) month_name integer months integer y integer year_length_months_hebrew ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST40' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_HEBREW names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_hebrew ( y ) do i = 1, months m = i call month_to_month_name_hebrew ( y, m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test41 ! !******************************************************************************* ! !! TEST41 tests MONTH_TO_MONTH_NAME_HINDU_LUNAR. ! integer i integer j integer m character ( len = 10 ) month_name integer months integer y integer year_length_months_hindu_lunar ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST41' write ( *, '(a)' ) ' For the Hindu lunar calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_HINDU_LUNAR names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_hindu_lunar ( y ) do i = 1, months m = i call month_to_month_name_hindu_lunar ( m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test415 ! !******************************************************************************* ! !! TEST415 tests MONTH_TO_MONTH_NAME_HINDU_SOLAR. ! integer i integer j integer m character ( len = 10 ) month_name integer months integer y integer year_length_months_hindu_solar ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST415' write ( *, '(a)' ) ' For the Hindu solar calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_HINDU_SOLAR names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_hindu_solar ( y ) do i = 1, months m = i call month_to_month_name_hindu_solar ( m, month_name ) write ( *, '(2x,i2,2x,a)' ) m, month_name end do return end subroutine test42 ! !******************************************************************************* ! !! TEST42 tests MONTH_TO_MONTH_NAME_ISLAMIC. ! integer i integer j integer m character ( len = 10 ) month_name integer months integer y integer year_length_months_islamic ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST42' write ( *, '(a)' ) ' For the Islamic calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_ISLAMIC names the months:' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_islamic ( y ) do i = 1, months m = i call month_to_month_name_islamic ( m, month_name ) write ( *, '(i4,2x,a)' ) m, month_name end do return end subroutine test43 ! !******************************************************************************* ! !! TEST43 tests MONTH_TO_MONTH_NAME_REPUBLICAN. ! integer m integer months character ( len = 15 ) month_name integer y integer year_length_months_republican ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST43' write ( *, '(a)' ) ' For the Republican calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_REPUBLICAN names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_republican ( y ) do m = 1, months call month_to_month_name_republican ( m, month_name ) write ( *, '(i4,2x,a)' ) m, month_name end do return end subroutine test435 ! !******************************************************************************* ! !! TEST435 tests MONTH_TO_MONTH_NAME_ROMAN. ! integer m integer months character ( len = 10 ) month_name integer y integer year_length_months_roman ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST435' write ( *, '(a)' ) ' For the Roman calendar,' write ( *, '(a)' ) ' MONTH_TO_MONTH_NAME_ROMAN names the months.' write ( *, '(a)' ) ' ' y = 1 months = year_length_months_roman ( y ) do m = 1, months call month_to_month_name_roman ( m, month_name ) write ( *, '(i4,2x,a)' ) m, month_name end do return end subroutine test44 ! !******************************************************************************* ! !! TEST44 tests MOON_PHASE_TO_JED. ! integer d integer d2 double precision f integer h double precision jed integer m integer min integer nphase integer phase integer s character ( len = 22 ) string integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST44' write ( *, '(a)' ) ' MOON_PHASE_TO_JED reports the JED on' write ( *, '(a)' ) ' which a phase of the moon occurs.' write ( *, '(a)' ) ' ' phase = 2 write ( *, '(a)' ) ' N JED YMDHMS date' write ( *, '(a)' ) ' ' do nphase = 1, 10 call moon_phase_to_jed ( nphase, phase, jed ) call jed_to_ymdf_common ( jed, y, m, d, f ) call frac_to_hms ( f, h, min, s ) call ymdhms_to_s_common ( y, m, d, h, min, s, string ) write ( *, '(2x,i3,f11.2,3x,a)' ) nphase, jed, string end do return end subroutine test45 ! !******************************************************************************* ! !! TEST45 tests NEW_YEAR_TO_JED_HEBREW. ! integer d3 double precision f3 integer i double precision jed2 integer m3 character ( len = 10 ) s1 character ( len = 20 ) s3 integer y1 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST45' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' NEW_YEAR_TO_JED_HEBREW determines the JED of' write ( *, '(a)' ) ' the first day of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YEAR JED YMDF' write ( *, '(a)' ) ' Hebrew Common' write ( *, '(a)' ) ' ' do i = 0, 20 y1 = 5760 + i call y_to_s_hebrew ( y1, s1 ) call new_year_to_jed_hebrew ( y1, jed2 ) call jed_to_ymdf_common ( jed2, y3, m3, d3, f3 ) call ymdf_to_s_common ( y3, m3, d3, f3, s3 ) write ( *, '(2x,a,2x,f11.2,5x,a)' ) trim ( s1 ), jed2, s3 end do return end subroutine test46 ! !******************************************************************************* ! !! TEST46 tests NOW_TO_JED. !! TEST46 tests NOW_TO_YJF_COMMON. !! TEST46 tests NOW_TO_YMDF_COMMON. !! TEST46 tests NOW_TO_YMDHMS_COMMON. ! integer d character ( len = 8 ) date double precision f integer h double precision jed integer j integer m integer n character ( len = 30 ) s integer second character ( len = 10 ) time integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST46' write ( *, '(a)' ) ' For the current time and date, "NOW", ' write ( *, '(a)' ) ' NOW_TO_JED returns the JED,' write ( *, '(a)' ) ' NOW_TO_YJF_COMMON the YJF date,' write ( *, '(a)' ) ' NOW_TO_YMDF_COMMON returns the YMDF date,' write ( *, '(a)' ) ' NOW_TO_YMDHMS_COMMON the YMDHMS date.' write ( *, '(a)' ) ' ' call date_and_time ( date, time ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' FORTRAN90 DATE_AND_TIME routine says:' write ( *, '(a)' ) ' Now is ' // trim ( date ) // ' ' // trim ( time ) call now_to_jed ( jed ) write ( *, '(a)' ) ' ' write ( *, '(a,f11.2)' ) ' NOW_TO_JED_COMMON: Now is: ', jed call now_to_yjf_common ( y, j, f ) call yjf_to_s_common ( y, j, f, s ) write ( *, '(a)' ) ' NOW_TO_YJF_COMMON: Now is: ' // trim ( s ) call now_to_ymdf_common ( y, m, d, f ) call ymdf_to_s_common ( y, m, d, f, s ) write ( *, '(a)' ) ' NOW_TO_YMDF_COMMON: Now is: ' // trim ( s ) call now_to_ymdhms_common ( y, m, d, h, n, second ) call ymdhms_to_s_common ( y, m, d, h, n, second, s ) write ( *, '(a)' ) ' NOW_TO_YMDHMS_COMMON: Now is: ' // trim ( s ) return end subroutine test47 ! !******************************************************************************* ! !! TEST47 tests S_TO_HMS. ! integer h2 integer m2 character ( len = 15 ) p character ( len = 15 ) s1 integer s2 character ( len = 8 ) s3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST47' write ( *, '(a)' ) ' S_TO_HMS converts a string to an HMS date.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ------S-------- ------P-------- HH:MM:SS' write ( *, '(a)' ) ' ' s1 = '10:30:44' p = 'hh:mm:ss' call s_to_hms ( s1, p, h2, m2, s2 ) call hms_to_s ( h2, m2, s2, s3 ) write ( *, '(2x,a,2x,a,2x,a)' ) s1, p, s3 s1 = '10 past 9' p = 'mm xxxx h' call s_to_hms ( s1, p, h2, m2, s2 ) call hms_to_s ( h2, m2, s2, s3 ) write ( *, '(2x,a,2x,a,2x,a)' ) s1, p, s3 return end subroutine test48 ! !******************************************************************************* ! !! TEST48 tests S_TO_YMD_COMMON. ! integer, parameter :: n_test = 5 ! integer d integer i_test integer m character ( len = 35 ) p character ( len = 35 ) p_test(n_test) character ( len = 35 ) s character ( len = 35 ) s_test(n_test) integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST48' write ( *, '(a)' ) ' S_TO_YMD_COMMON converts a string to a YMD date.' write ( *, '(a)' ) ' ' s_test(1) = '1999-10-31' p_test(1) = 'yyyy-mm-dd' s_test(2) = '01/04/2004' p_test(2) = 'dd/mm/yyyy' s_test(3) = '8/8/88' p_test(3) = 'd/m/yy' s_test(4) = '4 7' p_test(4) = 'd m' s_test(5) = 'On day 1 of month 3 of year 1945' p_test(5) = 'xx xxx d xx xxxxx m xx xxxx yyyy' do i_test = 1, n_test s = s_test(i_test) p = p_test(i_test) call s_to_ymd_common ( s, p, y, m, d ) write ( *, '(a)' ) ' ' write ( *, '(2x,a)' ) s write ( *, '(2x,a)' ) p write ( *, '(a)' ) ' ' write ( *, '(3i6)' ) y, m, d end do return end subroutine test49 ! !******************************************************************************* ! !! TEST49 tests S_TO_YMDHMS_COMMON. ! integer, parameter :: n_test = 2 ! integer d integer h integer i_test integer m integer n character ( len = 35 ) p character ( len = 35 ) p_test(n_test) character ( len = 35 ) s character ( len = 35 ) s_test(n_test) integer second integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST49' write ( *, '(a)' ) ' S_TO_YMDHMS_COMMON converts a string to a YMDHMS date.' write ( *, '(a)' ) ' ' s_test(1) = '1999-10-31-14-59-47' p_test(1) = 'YYYY-MM-DD-hh-mm-ss' s_test(2) = '8:30, 01 April 2004' p_test(2) = 'h:mm, DD NNNNN YYYY' do i_test = 1, n_test s = s_test(i_test) p = p_test(i_test) call s_to_ymdhms_common ( s, p, y, m, d, h, n, second ) write ( *, '(a)' ) ' ' write ( *, '(2x,a)' ) s write ( *, '(2x,a)' ) p write ( *, '(a)' ) ' ' write ( *, '(6i6)' ) y, m, d, h, n, second end do return end subroutine test495 ! !******************************************************************************* ! !! TEST495 tests WEEKDAY_TO_NAME_BAHAI. ! implicit none ! integer i character ( len = 15 ) s ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST495' write ( *, '(a)' ) ' For the Bahai calendar:' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_BAHAI names the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_bahai ( i, s ) write ( *, '(2x,i2,2x,a,2x,a)' ) i, s end do return end subroutine test50 ! !******************************************************************************* ! !! TEST50 tests WEEKDAY_TO_NAME_COMMON. !! TEST50 tests WEEKDAY_TO_NAME_COMMON2. ! implicit none ! integer i character ( len = 10 ) s1 character ( len = 2 ) s2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST50' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_COMMON names the days of the week,' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_COMMON2 abbreviates the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_common ( i, s1 ) call weekday_to_name_common2 ( i, s2 ) write ( *, '(i4,2x,a,2x,a)' ) i, s1, s2 end do return end subroutine test501 ! !******************************************************************************* ! !! TEST501 tests WEEKDAY_TO_NAME_GERMAN. ! implicit none ! integer i character ( len = 15 ) sname ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST501' write ( *, '(a)' ) ' For the German calendar,' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_GERMAN names the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_german ( i, sname ) write ( *, '(2x,i2,2x,a)' ) i, sname end do return end subroutine test502 ! !******************************************************************************* ! !! TEST502 tests WEEKDAY_TO_NAME_HEBREW. ! implicit none ! integer i character ( len = 15 ) sname ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST502' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_HEBREW names the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_hebrew ( i, sname ) write ( *, '(2x,i2,2x,a)' ) i, sname end do return end subroutine test503 ! !******************************************************************************* ! !! TEST503 tests WEEKDAY_TO_NAME_ISLAMIC. ! implicit none ! integer i character ( len = 15 ) sname ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST503' write ( *, '(a)' ) ' For the Islamic calendar,' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_ISLAMIC names the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_islamic ( i, sname ) write ( *, '(2x,i2,2x,a)' ) i, sname end do return end subroutine test51 ! !******************************************************************************* ! !! TEST51 tests WEEKDAY_TO_NAME_REPUBLICAN. ! implicit none ! integer i character ( len = 15 ) sname ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST51' write ( *, '(a)' ) ' For the Republican calendar,' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_REPUBLICAN names the days of the week.' write ( *, '(a)' ) ' ' do i = 1, 10 call weekday_to_name_republican ( i, sname ) write ( *, '(2x,i2,2x,a)' ) i, sname end do return end subroutine test515 ! !******************************************************************************* ! !! TEST515 tests WEEKDAY_TO_NAME_ROMAN. ! implicit none ! integer i character ( len = 15 ) sname ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST515' write ( *, '(a)' ) ' WEEKDAY_TO_NAME_ROMAN names the days of ' write ( *, '(a)' ) ' the week in the Roman calendar.' write ( *, '(a)' ) ' ' do i = 1, 7 call weekday_to_name_roman ( i, sname ) write ( *, '(2x,i2,2x,a)' ) i, sname end do return end subroutine test5153 ! !******************************************************************************* ! !! TEST5153 tests YEAR_CAL_COMMON. ! implicit none ! integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST5153' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' YEAR_CAL_COMMON prints a year calendar.' write ( *, '(a)' ) ' ' y = 1968 call year_cal_common ( y ) return end subroutine test51535 ! !******************************************************************************* ! !! TEST5154 tests YEAR_IS_EMBOLISMIC_EG_LUNAR. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_embolismic_eg_lunar ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST51535' write ( *, '(a)' ) ' For the Egyptian Lunar calendar:' write ( *, '(a)' ) ' YEAR_IS_EMBOLISMIC_EG_LUNAR determines if a year is' write ( *, '(a)' ) ' an embolismic year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Embolismic?' write ( *, '(a)' ) ' ' do y = 1, 25 call y_to_s_eg_lunar ( y, sy ) write ( *, '(4x,a,2x,l1)' ) sy, year_is_embolismic_eg_lunar ( y ) end do return end subroutine test5154 ! !******************************************************************************* ! !! TEST5154 tests YEAR_IS_EMBOLISMIC_GREEK. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_embolismic_greek ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST5154' write ( *, '(a)' ) ' For the Greek calendar:' write ( *, '(a)' ) ' YEAR_IS_EMBOLISMIC_GREEK determines if a year is' write ( *, '(a)' ) ' an embolismic year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Embolismic?' write ( *, '(a)' ) ' ' do y = 1, 20 call y_to_s_greek ( y, sy ) write ( *, '(4x,a,2x,l1)' ) sy, year_is_embolismic_greek ( y ) end do return end subroutine test5155 ! !******************************************************************************* ! !! TEST5155 tests YEAR_IS_EMBOLISMIC_HEBREW. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_embolismic_hebrew ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST5155' write ( *, '(a)' ) ' For the Hebrew calendar:' write ( *, '(a)' ) ' YEAR_IS_EMBOLISMIC_HEBREW determines if a Hebrew year is' write ( *, '(a)' ) ' an embolismic year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Embolismic?' write ( *, '(a)' ) ' ' do y = 1, 20 call y_to_s_hebrew ( y, sy ) write ( *, '(4x,a,2x,l1)' ) trim ( sy ), year_is_embolismic_hebrew ( y ) end do return end subroutine test5156 ! !******************************************************************************* ! !! TEST5156 tests YEAR_IS_LEAP_BAHAI. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_bahai ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST5156' write ( *, '(a)' ) ' For the Bahai calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_BAHAI reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1990, 2000 call y_to_s_bahai ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_bahai ( y ) end do return end subroutine test52 ! !******************************************************************************* ! !! TEST52 tests YEAR_IS_LEAP_COMMON. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_common ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST52' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_COMMON reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1990, 2000 call y_to_s_common ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_common ( y ) end do return end subroutine test525 ! !******************************************************************************* ! !! TEST525 tests YEAR_IS_LEAP_EG_LUNAR. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_eg_lunar ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST525' write ( *, '(a)' ) ' For the Egyptian Lunar calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_EG_LUNAR reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1, 10 call y_to_s_eg_lunar ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_eg_lunar ( y ) end do return end subroutine test53 ! !******************************************************************************* ! !! TEST53 tests YEAR_IS_LEAP_ENGLISH. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_english ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST53' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_ENGLISH reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1990, 2000 call y_to_s_english ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_english ( y ) end do return end subroutine test535 ! !******************************************************************************* ! !! TEST535 tests YEAR_IS_LEAP_GREEK. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_greek ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST535' write ( *, '(a)' ) ' For the Greek calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_GREEK reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1, 10 call y_to_s_greek ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_greek ( y ) end do return end subroutine test54 ! !******************************************************************************* ! !! TEST54 tests YEAR_IS_LEAP_GREGORIAN. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_gregorian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST54' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_GREGORIAN reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1990, 2000 call y_to_s_gregorian ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_gregorian ( y ) end do return end subroutine test555 ! !******************************************************************************* ! !! TEST555 tests YEAR_IS_LEAP_ISLAMIC. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_islamic ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST555' write ( *, '(a)' ) ' For the Islamic calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_ISLAMIC reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 500, 510 call y_to_s_islamic ( y, sy ) write ( *, '(2x,a,2x,l1)' ) trim ( sy ), year_is_leap_islamic ( y ) end do return end subroutine test56 ! !******************************************************************************* ! !! TEST56 tests YEAR_IS_LEAP_JULIAN. ! implicit none ! character ( len = 10 ) sy integer y logical year_is_leap_julian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST56' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_JULIAN reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1990, 2000 call y_to_s_julian ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_julian ( y ) end do return end subroutine test565 ! !******************************************************************************* ! !! TEST565 tests YEAR_IS_LEAP_REPUBLICAN. ! implicit none ! character ( len = 7 ) sy integer y logical year_is_leap_republican ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST565' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_REPUBLICAN reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 1, 6 call y_to_s_republican ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_republican ( y ) end do return end subroutine test566 ! !******************************************************************************* ! !! TEST566 tests YEAR_IS_LEAP_ROMAN. ! implicit none ! character ( len = 20 ) sy integer y logical year_is_leap_roman ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST566' write ( *, '(a)' ) ' For the Roman calendar:' write ( *, '(a)' ) ' YEAR_IS_LEAP_ROMAN reports leap years.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Leap?' write ( *, '(a)' ) ' ' do y = 96, 100 call y_to_s_roman ( y, sy ) write ( *, '(2x,a,2x,l1)' ) sy, year_is_leap_roman ( y ) end do return end subroutine test57 ! !******************************************************************************* ! !! TEST57 tests YEAR_LENGTH_COMMON. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_common ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST57' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_COMMON determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1580, 1585 call y_to_s_common ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_common ( y ) end do do y = 1750, 1755 call y_to_s_common ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_common ( y ) end do do y = 1000, 2000, 100 call y_to_s_common ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_common ( y ) end do return end subroutine test58 ! !******************************************************************************* ! !! TEST58 tests YEAR_LENGTH_ENGLISH. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_english ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST58' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_ENGLISH determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1580, 1585 call y_to_s_english ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_english ( y ) end do do y = 1750, 1755 call y_to_s_english ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_english ( y ) end do do y = 1000, 2000, 100 call y_to_s_english ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_english ( y ) end do return end subroutine test585 ! !******************************************************************************* ! !! TEST585 tests YEAR_LENGTH_GREEK. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_greek ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST585' write ( *, '(a)' ) ' For the Greek calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_GREEK determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1, 10 call y_to_s_greek ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_greek ( y ) end do return end subroutine test59 ! !******************************************************************************* ! !! TEST59 tests YEAR_LENGTH_GREGORIAN. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_gregorian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST59' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_GREGORIAN determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1580, 1585 call y_to_s_gregorian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_gregorian ( y ) end do do y = 1750, 1755 call y_to_s_gregorian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_gregorian ( y ) end do do y = 1000, 2000, 100 call y_to_s_gregorian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_gregorian ( y ) end do return end subroutine test60 ! !******************************************************************************* ! !! TEST60 tests YEAR_LENGTH_HEBREW. ! implicit none ! character ( len = 10 ) sy integer y integer year_length_hebrew ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST60' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' YEAR_LENGTH_HEBREW determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 5760, 5780 call y_to_s_hebrew ( y, sy ) write ( *, '(2x,a,2x,i6)' ) trim ( sy ), year_length_hebrew ( y ) end do return end subroutine test605 ! !******************************************************************************* ! !! TEST605 tests YEAR_LENGTH_ISLAMIC. ! implicit none ! character ( len = 10 ) sy integer y integer year_length_islamic ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST605' write ( *, '(a)' ) ' For the Islamic calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_ISLAMIC determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 500, 505 call y_to_s_islamic ( y, sy ) write ( *, '(2x,a,2x,i6)' ) trim ( sy ), year_length_islamic ( y ) end do return end subroutine test61 ! !******************************************************************************* ! !! TEST61 tests YEAR_LENGTH_JULIAN. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_julian ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST61' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_JULIAN determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1580, 1585 call y_to_s_julian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_julian ( y ) end do do y = 1750, 1755 call y_to_s_julian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_julian ( y ) end do do y = 1000, 2000, 100 call y_to_s_julian ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_julian ( y ) end do return end subroutine test615 ! !******************************************************************************* ! !! TEST615 tests YEAR_LENGTH_REPUBLICAN. ! implicit none ! integer i character ( len = 10 ) sy integer y integer year_length_republican ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST615' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_REPUBLICAN determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 1, 6 call y_to_s_republican ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_republican ( y ) end do return end subroutine test616 ! !******************************************************************************* ! !! TEST616 tests YEAR_LENGTH_ROMAN. ! implicit none ! integer i character ( len = 20 ) sy integer y integer year_length_roman ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST616' write ( *, '(a)' ) ' For the Roman calendar:' write ( *, '(a)' ) ' YEAR_LENGTH_ROMAN determines the length of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Length' write ( *, '(a)' ) ' ' do y = 96, 100 call y_to_s_roman ( y, sy ) write ( *, '(2x,a,2x,i6)' ) sy, year_length_roman ( y ) end do return end subroutine test62 ! !******************************************************************************* ! !! TEST62 tests YEAR_TO_DOMINICAL_COMMON. ! implicit none ! character d1 character d2 character i_to_a integer n1 integer n2 character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST62' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' YEAR_TO_DOMINICAL_COMMON determines the dominical number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Dominical Number' write ( *, '(a)' ) ' ' do y = 1577, 1587 call y_to_s_common ( y, s ) call year_to_dominical_common ( y, n1, n2 ) d1 = i_to_a ( n1 ) if ( n1 == n2 ) then write ( *, '(2x,a,2x,i1,2x,a1)' ) s, n1, d1 else d2 = i_to_a ( n2 ) write ( *, '(2x,a,2x,i1,2x,a1,2x,i1,2x,a1)' ) s, n1, d1, n2, d2 end if end do return end subroutine test621 ! !******************************************************************************* ! !! TEST621 tests YEAR_TO_DOMINICAL_GREGORIAN. ! implicit none ! character d1 character d2 character i_to_a integer n1 integer n2 character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST621' write ( *, '(a)' ) ' For the Gregorian calendar,' write ( *, '(a)' ) ' YEAR_TO_DOMINICAL_GREGORIAN determines the dominical number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Dominical Number' write ( *, '(a)' ) ' ' do y = 1577, 1587 call y_to_s_gregorian ( y, s ) call year_to_dominical_gregorian ( y, n1, n2 ) d1 = i_to_a ( n1 ) if ( n1 == n2 ) then write ( *, '(2x,a,2x,i1,2x,a1)' ) s, n1, d1 else d2 = i_to_a ( n2 ) write ( *, '(2x,a,2x,i1,2x,a1,2x,i1,2x,a1)' ) s, n1, d1, n2, d2 end if end do return end subroutine test622 ! !******************************************************************************* ! !! TEST622 tests YEAR_TO_DOMINICAL_JULIAN. ! implicit none ! character d1 character d2 character i_to_a integer n1 integer n2 character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST622' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' YEAR_TO_DOMINICAL_JULIAN determines the dominical number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Dominical Number' write ( *, '(a)' ) ' ' do y = 1577, 1587 call y_to_s ( y, s ) call year_to_dominical_julian ( y, n1, n2 ) d1 = i_to_a ( n1 ) if ( n1 == n2 ) then write ( *, '(2x,a,2x,i1,2x,a1)' ) s, n1, d1 else d2 = i_to_a ( n2 ) write ( *, '(2x,a,2x,i1,2x,a1,2x,i1,2x,a1)' ) s, n1, d1, n2, d2 end if end do return end subroutine test623 ! !******************************************************************************* ! !! TEST623 tests YEAR_TO_EPACT_GREGORIAN. ! implicit none ! integer e character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST623' write ( *, '(a)' ) ' For the Gregorian calendar,' write ( *, '(a)' ) ' YEAR_TO_EPACT_GREGORIAN determines the epact of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Epact' write ( *, '(a)' ) ' ' do y = -2, 20 if ( y /= 0 ) then call y_to_s_gregorian ( y, s ) call year_to_epact_gregorian ( y, e ) write ( *, '(2x,a,2x,i6)' ) s, e end if end do return end subroutine test624 ! !******************************************************************************* ! !! TEST624 tests YEAR_TO_EPACT_JULIAN. ! implicit none ! integer e character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST624' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' YEAR_TO_EPACT_JULIAN determines the epact of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Epact' write ( *, '(a)' ) ' ' do y = -2, 20 if ( y /= 0 ) then call y_to_s_julian ( y, s ) call year_to_epact_julian ( y, e ) write ( *, '(2x,a,2x,i6)' ) s, e end if end do return end subroutine test63 ! !******************************************************************************* ! !! TEST63 tests YEAR_TO_GOLDEN_NUMBER. ! implicit none ! integer g character ( len = 10 ) s integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST63' write ( *, '(a)' ) ' YEAR_TO_GOLDEN_NUMBER determines the golden' write ( *, '(a)' ) ' number of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Golden Number' write ( *, '(a)' ) ' ' do y = -2, 20 if ( y /= 0 ) then call y_to_s_common ( y, s ) call year_to_golden_number ( y, g ) write ( *, '(2x,a,2x,i6)' ) s, g end if end do return end subroutine test635 ! !******************************************************************************* ! !! TEST635 tests YEAR_TO_INDICTION_COMMON. ! implicit none ! integer i character ( len = 10 ) sy integer y integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST635' write ( *, '(a)' ) ' For a Common year,' write ( *, '(a)' ) ' YEAR_TO_INDICTION_COMMON determines the indiction number.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Indiction Number' write ( *, '(a)' ) ' ' do y = -1, 13 call y_astronomical_to_common ( y, y2 ) call y_to_s_common ( y2, sy ) call year_to_indiction_common ( y2, i ) write ( *, '(4x,a,2x,i2)' ) sy, i end do return end subroutine test636 ! !******************************************************************************* ! !! TEST636 tests YEAR_TO_SCALIGER_COMMON. ! implicit none ! integer c1 integer c2 integer c3 integer i integer r1 integer r2 integer r3 character ( len = 10 ) sy integer y integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST636' write ( *, '(a)' ) ' For a Common year,' write ( *, '(a)' ) ' YEAR_TO_SCALIGER_COMMON determines the Scaliger indices.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year Julian / Metonic / Indiction' write ( *, '(a)' ) ' ' do y = -4713, -4675 call y_astronomical_to_common ( y, y2 ) call y_to_s_common ( y2, sy ) call year_to_scaliger_common ( y2, c1, c2, c3, r1, r2, r3 ) write ( *, '(4x,a,2x,2i5,2x,2i5,2x,2i5)' ) sy, c1, r1, c2, r2, c3, r3 end do return end subroutine test64 ! !******************************************************************************* ! !! TEST64 tests YEAR_TO_TYPE_HEBREW. ! implicit none ! character ( len = 10 ) s integer type integer y ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST64' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' YEAR_TO_TYPE_HEBREW determines the type of a year.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Year TYPE' write ( *, '(a)' ) ' ' do y = 5760, 5780 call y_to_s_hebrew ( y, s ) call year_to_type_hebrew ( y, type ) write ( *, '(2x,a,2x,i6)' ) trim ( s ), type end do return end subroutine test65 ! !******************************************************************************* ! !! TEST65 tests YJF_DIF_COMMON. ! implicit none ! double precision days double precision f1 double precision f2 double precision, parameter :: fhi = 0.0D+00 double precision, parameter :: flo = 0.0D+00 integer i integer ierror integer j1 integer j2 integer, parameter :: jhi = 1 integer, parameter :: jlo = 1 character ( len = 20 ) s1 character ( len = 20 ) s2 integer y1 integer y2 integer, parameter :: yhi = 1970 integer, parameter :: ylo = 1960 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST65' write ( *, '(a)' ) ' For Common calendar YJF dates,' write ( *, '(a)' ) ' YJF_DIF_COMMON computes the day difference.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YJF1 YJF2 (YJF2 - YJF1)' write ( *, '(a)' ) ' ' do i = 1, 10 call yjf_random_common ( ylo, jlo, flo, yhi, jhi, fhi, y1, j1, f1 ) call yjf_to_s_common ( y1, j1, f1, s1 ) call yjf_random_common ( ylo, jlo, flo, yhi, jhi, fhi, y2, j2, f2 ) call yjf_to_s_common ( y2, j2, f2, s2 ) call yjf_dif_common ( y1, j1, f1, y2, j2, f2, days, ierror ) write ( *, '(2x,a,5x,a,5x,f11.2)' ) s1, s2, days end do return end subroutine test66 ! !******************************************************************************* ! !! TEST66 tests YJF_TO_WEEKDAY_COMMON. ! implicit none ! integer d1 double precision f1 double precision f2 double precision f3 integer i integer j2 double precision jed integer m1 character ( len = 20 ) s1 character ( len = 13 ) s2 character ( len = 11 ) s3 character ( len = 9 ) swkdy integer w3 integer y1 integer y2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST66' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' YJF_TO_WEEKDAY_COMMON reports day of week for a YJF date.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF YJF W Name' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_common ( jed, y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_common ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_common ( y2, j2, f2, s2 ) call yjf_to_weekday_common ( y2, j2, f2, w3 ) call weekday_to_name_common ( w3, s3 ) write ( *, '(f11.2,2x,a,2x,a,2x,i1,2x,a)' ) jed, s1, s2, w3, s3 end do return end subroutine test67 ! !******************************************************************************* ! !! TEST67 tests YJF_TO_YMDF_COMMON. !! TEST67 tests YMDF_TO_YJF_COMMON. ! implicit none ! integer d1 integer d3 integer, parameter :: dlo = 1 integer, parameter :: dhi = 1 double precision f1 double precision f2 double precision f3 double precision, parameter :: flo = 0.0 double precision, parameter :: fhi = 0.0 integer i integer ierror integer j integer j2 double precision jed integer m1 integer m3 integer, parameter :: mlo = 1 integer, parameter :: mhi = 1 character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 integer y1 integer y2 integer y3 integer, parameter :: ylo = 1960 integer, parameter :: yhi = 1970 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST67' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_COMMON: YJF => YMDF.' write ( *, '(a)' ) ' YMDF_TO_YJF_COMMON: YMDF => YJF.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF(in) YJF YMDF(out)' write ( *, '(a)' ) ' ' do i = 1, 10 call ymdf_random_common ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_common ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_common ( y2, j2, f2, s2 ) call yjf_to_ymdf_common ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_common ( y3, m3, d3, f3, s3 ) write ( *, '(2x,3a)' ) s1, s2, s3 end do return end subroutine test675 ! !******************************************************************************* ! !! TEST675 tests YJF_TO_YMDF_ENGLISH. !! TEST675 tests YMDF_TO_YJF_ENGLISH. ! implicit none ! integer d1 integer d3 double precision f1 double precision f2 double precision f3 integer i integer ierror integer j integer j2 double precision jed double precision jed_epoch integer m1 integer m3 character ( len = 15 ) s1 character ( len = 15 ) s2 character ( len = 15 ) s3 integer y1 integer y2 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST675' write ( *, '(a)' ) ' For the English calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_ENGLISH: YJF => YMDF.' write ( *, '(a)' ) ' YMDF_TO_YJF_ENGLISH: YMDF => YJF.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF(in) YJF YMDF(out)' write ( *, '(a)' ) ' ' call epoch_to_jed_english ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if if ( jed >= jed_epoch ) then call jed_to_ymdf_english ( jed, y1, m1, d1, f1 ) call ymdf_to_s_english ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_english ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_english ( y2, j2, f2, s2 ) call yjf_to_ymdf_english ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_english ( y3, m3, d3, f3, s3 ) write ( *, '(f11.2,2x,3a)' ) jed, s1, s2, s3 end if end do return end subroutine test68 ! !******************************************************************************* ! !! TEST68 tests YJF_TO_YMDF_HEBREW. !! TEST68 tests YMDF_TO_YJF_HEBREW. ! implicit none ! integer d1 integer d3 double precision f1 double precision f2 double precision f3 integer i integer ierror integer j integer j2 double precision jed_epoch double precision jed1 integer m1 integer m3 character ( len = 20 ) s1 character ( len = 15 ) s2 character ( len = 20 ) s3 integer y1 integer y2 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST68' write ( *, '(a)' ) ' For the Hebrew calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_HEBREW: YJF => YMDF' write ( *, '(a)' ) ' YMDF_TO_YJF_HEBREW: YMDF => YJF' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF(in) YJF YMDF(out)' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_hebrew ( jed1, y1, m1, d1, f1 ) call ymdf_to_s_hebrew ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_hebrew ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_hebrew ( y2, j2, f2, s2 ) call yjf_to_ymdf_hebrew ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_hebrew ( y3, m3, d3, f3, s3 ) write ( *, '(2x,3a)' ) s1, s2, s3 end if end do return end subroutine test685 ! !******************************************************************************* ! !! TEST685 tests YJF_TO_YMDF_ISLAMIC. !! TEST685 tests YMDF_TO_YJF_ISLAMIC. ! implicit none ! integer d1 integer d3 double precision f1 double precision f2 double precision f3 integer i integer ierror integer j integer j2 double precision jed_epoch double precision jed1 integer m1 integer m3 character ( len = 20 ) s1 character ( len = 15 ) s2 character ( len = 20 ) s3 integer y1 integer y2 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST685' write ( *, '(a)' ) ' For the Islamic calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_ISLAMIC: YJF => YMDF' write ( *, '(a)' ) ' YMDF_TO_YJF_ISLAMIC: YMDF => YJF' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF(in) YJF YMDF(out)' write ( *, '(a)' ) ' ' call epoch_to_jed_islamic_a ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_islamic_a ( jed1, y1, m1, d1, f1 ) call ymdf_to_s_islamic ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_islamic ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_islamic ( y2, j2, f2, s2 ) call yjf_to_ymdf_islamic ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_islamic ( y3, m3, d3, f3, s3 ) write ( *, '(2x,3a)' ) s1, s2, s3 end if end do return end subroutine test686 ! !******************************************************************************* ! !! TEST686 tests YJF_TO_YMDF_JULIAN. !! TEST686 tests YMDF_TO_YJF_JULIAN. ! implicit none ! integer d1 integer d3 double precision f1 double precision f2 double precision f3 integer i integer ierror integer j integer j2 double precision jed_epoch double precision jed1 integer m1 integer m3 character ( len = 20 ) s1 character ( len = 15 ) s2 character ( len = 20 ) s3 integer y1 integer y2 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST686' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_JULIAN: YJF => YMDF' write ( *, '(a)' ) ' YMDF_TO_YJF_JULIAN: YMDF => YJF' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF(in) YJF YMDF(out)' write ( *, '(a)' ) ' ' call epoch_to_jed_julian ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_julian ( jed1, y1, m1, d1, f1 ) call ymdf_to_s_julian ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_julian ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_julian ( y2, j2, f2, s2 ) call yjf_to_ymdf_julian ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_julian ( y3, m3, d3, f3, s3 ) write ( *, '(2x,3a)' ) s1, s2, s3 end if end do return end subroutine test687 ! !******************************************************************************* ! !! TEST687 tests YJF_TO_YMDF_ROMAN. !! TEST687 tests YMDF_TO_YJF_ROMAN. ! implicit none ! integer d1 integer d3 double precision f1 double precision f2 double precision f3 integer i integer ierror integer j integer j2 double precision jed_epoch double precision jed1 integer m1 integer m3 character ( len = 50 ) s1 character ( len = 15 ) s2 character ( len = 50 ) s3 integer y1 integer y2 integer y3 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST687' write ( *, '(a)' ) ' For the Roman calendar,' write ( *, '(a)' ) ' YJF_TO_YMDF_ROMAN: YJF => YMDF' write ( *, '(a)' ) ' YMDF_TO_YJF_ROMAN: YMDF => YJF' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF(in) YJF' write ( *, '(a)' ) ' YMDF(out)' write ( *, '(a)' ) ' ' call epoch_to_jed_roman ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed1 ) if ( jed1 < 0.0D+00 ) then exit end if if ( jed1 >= jed_epoch ) then call jed_to_ymdf_roman ( jed1, y1, m1, d1, f1 ) call ymdf_to_s_roman ( y1, m1, d1, f1, s1 ) call ymdf_to_yjf_roman ( y1, m1, d1, f1, y2, j2, f2 ) call yjf_to_s_roman ( y2, j2, f2, s2 ) call yjf_to_ymdf_roman ( y2, j2, f2, y3, m3, d3, f3 ) call ymdf_to_s_roman ( y3, m3, d3, f3, s3 ) write ( *, '(a)' ) ' ' write ( *, '(2x,3a)' ) s1, s2 write ( *, '(2x,3a)' ) s3 end if end do return end subroutine test688 ! !******************************************************************************* ! !! TEST688 tests YJF_TO_YMDHMS_COMMON. !! TEST688 tests YMDHMS_TO_YJF_COMMON. ! implicit none ! integer d2 double precision f1 double precision f3 double precision, parameter :: flo = 0.0D+00 double precision, parameter :: fhi = 0.0D+00 integer h2 integer i integer j1 integer j3 integer, parameter :: jlo = 1 integer, parameter :: jhi = 1 integer m2 integer n2 integer s2 character ( len = 20 ) ss1 character ( len = 22 ) ss2 character ( len = 20 ) ss3 integer y1 integer y2 integer y3 integer, parameter :: ylo = 1960 integer, parameter :: yhi = 1970 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST688' write ( *, '(a)' ) ' YJF_TO_YMDHMS_COMMON: YJF => YMDHMS' write ( *, '(a)' ) ' YMDHMS_TO_YJF_COMMON: YMDHMS => YJF' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YJF (in) YMDHMS YJF(out)' write ( *, '(a)' ) ' ' do i = 1, 5 call yjf_random_common ( ylo, jlo, flo, yhi, jhi, fhi, y1, j1, f1 ) call yjf_to_s_common ( y1, j1, f1, ss1 ) call yjf_to_ymdhms_common ( y1, j1, f1, y2, m2, d2, h2, n2, s2 ) call ymdhms_to_s_common ( y2, m2, d2, h2, n2, s2, ss2 ) call ymdhms_to_yjf_common ( y2, m2, d2, h2, n2, s2, y3, j3, f3 ) call yjf_to_s_common ( y3, j3, f3, ss3 ) write ( *, '(2x,a,2x,a,2x,a)' ) ss1, ss2, ss3 end do return end subroutine test69 ! !******************************************************************************* ! !! TEST69 tests YMDF_DIF_COMMON. ! implicit none ! integer d1 integer d2 double precision days integer, parameter :: dhi = 1 integer, parameter :: dlo = 1 double precision f1 double precision f2 double precision, parameter :: fhi = 0.0D+00 double precision, parameter :: flo = 0.0D+00 integer i integer ierror integer m1 integer m2 integer, parameter :: mhi = 1 integer, parameter :: mlo = 1 character ( len = 20 ) s1 character ( len = 20 ) s2 integer y1 integer y2 integer, parameter :: yhi = 1960 integer, parameter :: ylo = 1970 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST69' write ( *, '(a)' ) ' YMDF_DIF_COMMON gets the day difference between YMDF dates.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF1 YMDF2 (YMDF2 - YMDF1)' write ( *, '(a)' ) ' ' do i = 1, 10 call ymdf_random_common ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_random_common ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y2, m2, d2, f2 ) call ymdf_to_s_common ( y2, m2, d2, f2, s2 ) call ymdf_dif_common ( y1, m1, d1, f1, y2, m2, d2, f2, days, ierror ) write ( *, '(a,5x,a,5x,f11.2)' ) s1, s2, days end do return end subroutine test695 ! !******************************************************************************* ! !! TEST695 tests YMDF_DIF_ENGLISH. ! implicit none ! integer d1 integer d2 double precision days integer, parameter :: dhi = 1 integer, parameter :: dlo = 1 double precision f1 double precision f2 double precision, parameter :: fhi = 0.0D+00 double precision, parameter :: flo = 0.0D+00 integer i integer ierror integer m1 integer m2 integer, parameter :: mhi = 1 integer, parameter :: mlo = 1 character ( len = 20 ) s1 character ( len = 20 ) s2 integer y1 integer y2 integer, parameter :: yhi = 1960 integer, parameter :: ylo = 1970 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST695' write ( *, '(a)' ) ' YMDF_DIF_ENGLISH gets the day difference between YMDF dates.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF1 YMDF2 (YMDF2 - YMDF1)' write ( *, '(a)' ) ' ' do i = 1, 10 call ymdf_random_english ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y1, m1, d1, f1 ) call ymdf_to_s_english ( y1, m1, d1, f1, s1 ) call ymdf_random_english ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y2, m2, d2, f2 ) call ymdf_to_s_english ( y2, m2, d2, f2, s2 ) call ymdf_dif_english ( y1, m1, d1, f1, y2, m2, d2, f2, days, ierror ) write ( *, '(2x,a,5x,a,5x,f11.2)' ) s1, s2, days end do return end subroutine test70 ! !******************************************************************************* ! !! TEST70 tests YMDF_INC_COMMON. !! TEST70 tests YMDF_NEXT_COMMON. !! TEST70 tests YMDF_PREV_COMMON. ! implicit none ! integer d1 integer d2 integer d3 integer d4 double precision, parameter :: days = 10.25D+00 integer, parameter :: dhi = 1 integer, parameter :: dlo = 1 double precision f1 double precision f2 double precision f3 double precision f4 double precision, parameter :: fhi = 0.0D+00 double precision, parameter :: flo = 0.0D+00 integer i integer ierror double precision jed integer m1 integer m2 integer m3 integer m4 integer, parameter :: mhi = 1 integer, parameter :: mlo = 1 character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 character ( len = 20 ) s4 integer y1 integer y2 integer y3 integer y4 integer, parameter :: yhi = 1960 integer, parameter :: ylo = 1970 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST70' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' YMDF_INC_COMMON increments a date by days;' write ( *, '(a)' ) ' YMDF_NEXT_COMMON computes the next day,' write ( *, '(a)' ) ' YMDF_PREV_COMMON computes the previous day.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF Tomorrow Yesterday +10.25 days' write ( *, '(a)' ) ' ' do i = 1, 10 call ymdf_random_common ( ylo, mlo, dlo, flo, yhi, mhi, dhi, fhi, & y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_next_common ( y1, m1, d1, f1, y2, m2, d2, f2 ) call ymdf_to_s_common ( y2, m2, d2, f2, s2 ) call ymdf_prev_common ( y1, m1, d1, f1, y3, m3, d3, f3 ) call ymdf_to_s_common ( y3, m3, d3, f3, s3 ) call ymdf_inc_common ( y1, m1, d1, f1, days, y4, m4, d4, f4 ) call ymdf_to_s_common ( y4, m4, d4, f4, s4 ) write ( *, '(2x,4a)' ) s1, s2, s3, s4 end do return end subroutine test71 ! !******************************************************************************* ! !! TEST71 tests YMDF_INC_ENGLISH. !! TEST71 tests YMDF_NEXT_ENGLISH. !! TEST71 tests YMDF_PREV_ENGLISH. ! implicit none ! integer d1 integer d2 integer d3 integer d4 double precision, parameter :: days = 10.25D+00 double precision f1 double precision f2 double precision f3 double precision f4 integer i integer ierror double precision jed integer m1 integer m2 integer m3 integer m4 character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 character ( len = 20 ) s4 integer y1 integer y2 integer y3 integer y4 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST71' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' YMDF_INC_ENGLISH increments a date by days;' write ( *, '(a)' ) ' YMDF_NEXT_ENGLISH computes the next day,' write ( *, '(a)' ) ' YMDF_PREV_ENGLISH computes the previous day.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF Tomorrow Yesterday +10.25 days' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_english ( jed, y1, m1, d1, f1 ) call ymdf_to_s_english ( y1, m1, d1, f1, s1 ) call ymdf_next_english ( y1, m1, d1, f1, y2, m2, d2, f2 ) call ymdf_to_s_english ( y2, m2, d2, f2, s2 ) call ymdf_prev_english ( y1, m1, d1, f1, y3, m3, d3, f3 ) call ymdf_to_s_english ( y3, m3, d3, f3, s3 ) call ymdf_inc_english ( y1, m1, d1, f1, days, y4, m4, d4, f4 ) call ymdf_to_s_english ( y4, m4, d4, f4, s4 ) write ( *, '(2x,4a)' ) s1, s2, s3, s4 end do return end subroutine test72 ! !******************************************************************************* ! !! TEST72 tests YMDF_INC_GREGORIAN. !! TEST72 tests YMDF_NEXT_GREGORIAN. !! TEST72 tests YMDF_PREV_GREGORIAN. ! implicit none ! integer d1 integer d2 integer d3 integer d4 double precision, parameter :: days = 10.25D+00 double precision f1 double precision f2 double precision f3 double precision f4 integer i integer ierror double precision jed integer m1 integer m2 integer m3 integer m4 character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 character ( len = 20 ) s4 integer y1 integer y2 integer y3 integer y4 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST72' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' YMDF_INC_GREGORIAN increments a date by days;' write ( *, '(a)' ) ' YMDF_NEXT_GREGORIAN computes the next day,' write ( *, '(a)' ) ' YMDF_PREV_GREGORIAN computes the previous day.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF Tomorrow Yesterday +10.25 days' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_gregorian ( jed, y1, m1, d1, f1 ) call ymdf_to_s_gregorian ( y1, m1, d1, f1, s1 ) call ymdf_next_gregorian ( y1, m1, d1, f1, y2, m2, d2, f2 ) call ymdf_to_s_gregorian ( y2, m2, d2, f2, s2 ) call ymdf_prev_gregorian ( y1, m1, d1, f1, y3, m3, d3, f3 ) call ymdf_to_s_gregorian ( y3, m3, d3, f3, s3 ) call ymdf_inc_gregorian ( y1, m1, d1, f1, days, y4, m4, d4, f4 ) call ymdf_to_s_gregorian ( y4, m4, d4, f4, s4 ) write ( *, '(2x,4a)' ) s1, s2, s3, s4 end do return end subroutine test73 ! !******************************************************************************* ! !! TEST73 tests YMDF_INC_HEBREW. !! TEST73 tests YMDF_NEXT_HEBREW. !! TEST73 tests YMDF_PREV_HEBREW. ! implicit none ! integer d1 integer d2 integer d3 integer d4 double precision, parameter :: days = 10.25D+00 double precision f1 double precision f2 double precision f3 double precision f4 integer i integer ierror double precision jed double precision jed_epoch integer m1 integer m2 integer m3 integer m4 character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 character ( len = 20 ) s4 integer y1 integer y2 integer y3 integer y4 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST73' write ( *, '(a)' ) ' For the Hebrew calendar:' write ( *, '(a)' ) ' YMDF_INC_HEBREW increments a date by days;' write ( *, '(a)' ) ' YMDF_NEXT_HEBREW computes the next day,' write ( *, '(a)' ) ' YMDF_PREV_HEBREW computes the previous day.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF Tomorrow Yesterday +10.25 days' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if if ( jed >= jed_epoch + 1 ) then call jed_to_ymdf_hebrew ( jed, y1, m1, d1, f1 ) call ymdf_to_s_hebrew ( y1, m1, d1, f1, s1 ) call ymdf_next_hebrew ( y1, m1, d1, f1, y2, m2, d2, f2 ) call ymdf_to_s_hebrew ( y2, m2, d2, f2, s2 ) call ymdf_prev_hebrew ( y1, m1, d1, f1, y3, m3, d3, f3 ) call ymdf_to_s_hebrew ( y3, m3, d3, f3, s3 ) call ymdf_inc_hebrew ( y1, m1, d1, f1, days, y4, m4, d4, f4 ) call ymdf_to_s_hebrew ( y4, m4, d4, f4, s4 ) write ( *, '(2x,4a)' ) s1, s2, s3, trim ( s4 ) end if end do return end subroutine test74 ! !******************************************************************************* ! !! TEST74 tests YMDF_INC_JULIAN. !! TEST74 tests YMDF_NEXT_JULIAN. !! TEST74 tests YMDF_PREV_JULIAN. ! implicit none ! integer d1 integer d2 integer d3 integer d4 double precision, parameter :: days = 10.25D+00 double precision f1 double precision f2 double precision f3 double precision f4 integer i integer ierror double precision jed integer m1 integer m2 integer m3 integer m4 integer n character ( len = 20 ) s1 character ( len = 20 ) s2 character ( len = 20 ) s3 character ( len = 20 ) s4 integer y1 integer y2 integer y3 integer y4 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST74' write ( *, '(a)' ) ' For the Julian calendar:' write ( *, '(a)' ) ' YMDF_INC_JULIAN increments a date by days;' write ( *, '(a)' ) ' YMDF_NEXT_JULIAN computes the next day,' write ( *, '(a)' ) ' YMDF_PREV_JULIAN computes the previous day.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDF date Tomorrow Yesterday +10.25 days' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_julian ( jed, y1, m1, d1, f1 ) call ymdf_to_s_julian ( y1, m1, d1, f1, s1 ) call ymdf_next_julian ( y1, m1, d1, f1, y2, m2, d2, f2 ) call ymdf_to_s_julian ( y2, m2, d2, f2, s2 ) call ymdf_prev_julian ( y1, m1, d1, f1, y3, m3, d3, f3 ) call ymdf_to_s_julian ( y3, m3, d3, f3, s3 ) call ymdf_inc_julian ( y1, m1, d1, f1, days, y4, m4, d4, f4 ) call ymdf_to_s_julian ( y4, m4, d4, f4, s4 ) write ( *, '(2x,4a)' ) s1, s2, s3, s4 end do return end subroutine test75 ! !******************************************************************************* ! !! TEST75 tests YMD_INC_YMD_COMMON. !! TEST75 tests YMDF_DIF_YMDF_COMMON. ! implicit none ! integer d1 integer d2 integer dn1 integer dn2 double precision f1 double precision f2 double precision fn1 double precision fn2 integer i integer ierror integer m1 integer m2 integer mn1 integer mn2 integer n character ( len = 20 ) s1 character ( len = 20 ) s2 integer y1 integer y2 integer yn1 integer yn2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST75' write ( *, '(a)' ) ' For the Common calendar,' write ( *, '(a)' ) ' YMD_INC_YMD_COMMON increments a YMDF date by YMDF;' write ( *, '(a)' ) ' YMDF_DIF_YMDF_COMMON finds the YMDF difference.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Date1 increment Date2 difference' write ( *, '(a)' ) ' ' y1 = 1900 m1 = 5 d1 = 27 f1 = 0.0D+00 yn1 = 50 mn1 = 9 dn1 = 10 fn2 = 0.0D+00 call ymd_inc_ymd_common ( y1, m1, d1, yn1, mn1, dn1, y2, m2, d2 ) call ymdf_dif_ymdf_common ( y1, m1, d1, f1, y2, m2, d2, f2, yn2, mn2, dn2, & fn2, ierror ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_to_s_common ( y2, m2, d2, f2, s2 ) write ( *, '(2x,a,2x,3i3,2x,a,2x,3i3)' ) s1, yn1, mn1, dn1, s2, yn2, mn2, dn2 return end subroutine test76 ! !******************************************************************************* ! !! TEST76 tests YMDF_TO_WEEKDAY_COMMON. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed integer m1 character ( len = 20 ) s1 character ( len = 9 ) s2 integer w2 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST76' write ( *, '(a)' ) ' For the Common calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_COMMON returns the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_common ( jed, y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_common ( y1, m1, d1, f1, w2 ) call weekday_to_name_common ( w2, s2 ) write ( *, '(f11.2,2x,a,2x,i1,2x,a)' ) jed, s1, w2, s2 end do return end subroutine test77 ! !******************************************************************************* ! !! TEST77 tests YMDF_TO_WEEKDAY_ENGLISH. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed integer m1 character ( len = 20 ) s1 character ( len = 9 ) s2 integer w2 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST77' write ( *, '(a)' ) ' For the English calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_ENGLISH returns the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_english ( jed, y1, m1, d1, f1 ) call ymdf_to_s_english ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_english ( y1, m1, d1, f1, w2 ) call weekday_to_name_common ( w2, s2 ) write ( *, '(f11.2,2x,a,2x,i1,2x,a)' ) jed, s1, w2, s2 end do return end subroutine test78 ! !******************************************************************************* ! !! TEST78 tests YMDF_TO_WEEKDAY_GREGORIAN. !! TEST78 tests YMDF_TO_WEEKDAY_GREGORIAN2. !! TEST78 tests YMDF_TO_WEEKDAY_GREGORIAN3. !! TEST78 tests YMDF_TO_WEEKDAY_GREGORIAN4. !! TEST78 tests YMDF_TO_WEEKDAY_GREGORIAN5. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed integer m1 character ( len = 20 ) s1 character ( len = 9 ) s2 character ( len = 9 ) s3 character ( len = 9 ) s4 character ( len = 9 ) s5 character ( len = 9 ) s6 integer w2 integer w3 integer w4 integer w5 integer w6 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST78' write ( *, '(a)' ) ' For the Gregorian calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_GREGORIAN,' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_GREGORIAN2,' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_GREGORIAN3,' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_GREGORIAN4, and' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_GREGORIAN5' write ( *, '(a)' ) ' return the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' (This is "easy" to do for recent dates,' write ( *, '(a)' ) ' but look closely at early dates!)' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_gregorian ( jed, y1, m1, d1, f1 ) call ymdf_to_s_gregorian ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_gregorian ( y1, m1, d1, f1, w2 ) call weekday_to_name_common ( w2, s2 ) call ymdf_to_weekday_gregorian2 ( y1, m1, d1, f1, w3 ) call weekday_to_name_common ( w3, s3 ) call ymdf_to_weekday_gregorian3 ( y1, m1, d1, f1, w4 ) call weekday_to_name_common ( w4, s4 ) call ymdf_to_weekday_gregorian4 ( y1, m1, d1, f1, w5 ) call weekday_to_name_common ( w5, s5 ) call ymdf_to_weekday_gregorian5 ( y1, m1, d1, f1, w6 ) call weekday_to_name_common ( w6, s6 ) write ( *, '(f11.2, 2x, a, 5(2x,i1,2x,a) )' ) & jed, s1, w2, s2, w3, s3, w4, s4, w5, s5, w6, s6 end do return end subroutine test79 ! !******************************************************************************* ! !! TEST79 tests YMDF_TO_WEEKDAY_HEBREW. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed double precision jed_epoch integer m1 character ( len = 20 ) s1 character ( len = 15 ) s2 integer w2 integer w3 integer w4 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST79' write ( *, '(a)' ) ' For the HEBREW calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_HEBREW' write ( *, '(a)' ) ' returns the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' call epoch_to_jed_hebrew ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if if ( jed >= jed_epoch ) then call jed_to_ymdf_hebrew ( jed, y1, m1, d1, f1 ) call ymdf_to_s_hebrew ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_hebrew ( y1, m1, d1, f1, w2 ) call weekday_to_name_hebrew ( w2, s2 ) write ( *, '(f11.2,2x,a,2x,i1,2x,a)' ) jed, s1, w2, s2 end if end do return end subroutine test795 ! !******************************************************************************* ! !! TEST795 tests YMDF_TO_WEEKDAY_ISLAMIC_A. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed double precision jed_epoch integer m1 character ( len = 20 ) s1 character ( len = 15 ) s2 integer w2 integer w3 integer w4 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST795' write ( *, '(a)' ) ' For the Islamic-A calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_ISLAMIC_A' write ( *, '(a)' ) ' returns the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' call epoch_to_jed_islamic_a ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if if ( jed >= jed_epoch ) then call jed_to_ymdf_islamic_a ( jed, y1, m1, d1, f1 ) call ymdf_to_s_islamic ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_islamic_a ( y1, m1, d1, f1, w2 ) call weekday_to_name_islamic ( w2, s2 ) write ( *, '(f11.2,2x,a,2x,i1,2x,a)' ) jed, s1, w2, s2 end if end do return end subroutine test80 ! !******************************************************************************* ! !! TEST80 tests YMDF_TO_WEEKDAY_JULIAN. !! TEST80 tests YMDF_TO_WEEKDAY_JULIAN2. !! TEST80 tests YMDF_TO_WEEKDAY_JULIAN3. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed integer m1 character ( len = 20 ) s1 character ( len = 9 ) s2 character ( len = 9 ) s3 character ( len = 9 ) s4 integer w2 integer w3 integer w4 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST80' write ( *, '(a)' ) ' For the Julian calendar,' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_JULIAN,' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_JULIAN2, and' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_JULIAN3' write ( *, '(a)' ) ' return the day of the week of a given date.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_julian ( jed, y1, m1, d1, f1 ) call ymdf_to_s_julian ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_julian ( y1, m1, d1, f1, w2 ) call weekday_to_name_common ( w2, s2 ) call ymdf_to_weekday_julian2 ( y1, m1, d1, f1, w3 ) call weekday_to_name_common ( w3, s3 ) call ymdf_to_weekday_julian2 ( y1, m1, d1, f1, w4 ) call weekday_to_name_common ( w4, s4 ) write ( *, '(f11.2,2x,a,2x,i1,2x,a,2x,i1,2x,a,2x,i1,2x,a)' ) & jed, s1, w2, s2, w3, s3, w4, s4 end do return end subroutine test805 ! !******************************************************************************* ! !! TEST805 tests YMDF_TO_WEEKDAY_REPUBLICAN. ! implicit none ! integer d1 double precision f1 integer i integer ierror double precision jed double precision jed_epoch integer m1 character ( len = 20 ) s1 character ( len = 9 ) s2 integer w2 integer w3 integer w4 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST805' write ( *, '(a)' ) ' For the Republican calendar:' write ( *, '(a)' ) ' YMDF_TO_WEEKDAY_REPUBLICAN' write ( *, '(a)' ) ' returns the day of the week.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Day of the week' write ( *, '(a)' ) ' ' call epoch_to_jed_republican ( jed_epoch ) i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if if ( jed >= jed_epoch ) then call jed_to_ymdf_republican ( jed, y1, m1, d1, f1 ) call ymdf_to_s_republican ( y1, m1, d1, f1, s1 ) call ymdf_to_weekday_republican ( y1, m1, d1, f1, w2 ) call weekday_to_name_republican ( w2, s2 ) write ( *, '(2x,f11.2,2x,a,1x,i2,2x,a)' ) jed, s1, w2, s2 end if end do return end subroutine test81 ! !******************************************************************************* ! !! TEST81 tests YMDF_TO_WEEK_COMMON. ! implicit none ! integer d1 double precision f1 integer i integer ierror integer iweek double precision jed integer m1 character ( len = 20 ) s1 integer y1 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST81' write ( *, '(a)' ) ' YMDF_TO_WEEK_COMMON reports week number for a YMDF date.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' JED YMDF Week' write ( *, '(a)' ) ' ' i = 0 do i = i + 1 call jed_test ( i, jed ) if ( jed < 0 ) then exit end if call jed_to_ymdf_common ( jed, y1, m1, d1, f1 ) call ymdf_to_s_common ( y1, m1, d1, f1, s1 ) call ymdf_to_week_common ( y1, m1, d1, f1, iweek ) write ( *, '(2x,f11.2,2x,a,2x,i2)' ) jed, s1, iweek end do return end subroutine test82 ! !******************************************************************************* ! !! TEST82 tests YMDHMS_DIF_DHMS. ! implicit none ! integer d1 integer d2 integer days integer h1 integer h2 integer hours integer ierror integer m1 integer m2 integer minutes integer n1 integer n2 integer seconds integer second1 integer second2 character ( len = 22 ) s1 character ( len = 22 ) s2 integer y1 integer y2 ! y1 = 1997 m1 = 02 d1 = 12 h1 = 13 n1 = 12 second1 = 33 y2 = 1997 m2 = 03 d2 = 14 h2 = 4 n2 = 21 second2 = 33 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST82' write ( *, '(a)' ) ' YMDHMS_DIF_DHMS finds the DHMS difference' write ( *, '(a)' ) ' between YMDHMS dates.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' YMDHMS 1 YMDHMS 2 ' // & ' Difference' write ( *, '(a)' ) ' ' // & ' D H M S' write ( *, '(a)' ) ' ' call ymdhms_to_s_common ( y1, m1, d1, h1, n1, second1, s1 ) call ymdhms_to_s_common ( y2, m2, d2, h2, n2, second2, s2 ) call ymdhms_dif_dhms ( y1, m1, d1, h1, n1, second1, & y2, m2, d2, h2, n2, second2, days, hours, minutes, seconds, ierror ) write ( *, '(2x,a,2x,a,2x,4i4)' ) s1, s2, days, hours, minutes, seconds return end