92 #include <fms_platform.h> 104 public operator(+),
operator(-),
operator(*),
operator(/), &
105 operator(>),
operator(>=),
operator(==),
operator(/=), &
106 operator(<),
operator(<=),
operator(//),
assignment(=)
158 integer,
private ::
days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
176 interface operator (+); module
procedure time_plus; end interface
177 interface operator (-); module
procedure time_minus; end interface
178 interface operator (*); module
procedure time_scalar_mult
180 interface operator (/); module
procedure time_scalar_divide
182 interface operator (>); module
procedure time_gt; end interface
183 interface operator (>=); module
procedure time_ge; end interface
184 interface operator (<); module
procedure time_lt; end interface
185 interface operator (<=); module
procedure time_le; end interface
186 interface operator (==); module
procedure time_eq; end interface
187 interface operator (/=); module
procedure time_ne; end interface
188 interface operator (//); module
procedure time_real_divide; end interface
189 interface assignment(=); module
procedure time_assignment; end interface
204 #include<file_version.h> 297 integer,
intent(in) :: seconds, days, ticks
299 character(len=*),
intent(out) :: err_msg
300 integer :: seconds_new, days_new, ticks_new
307 if ( seconds_new < 0 .or. ticks_new < 0)
then 308 call error_mesg(
'function set_time_i',
'Bad result for time. Contact those responsible for maintaining time_manager',fatal)
311 if(days_new < 0)
then 312 write(err_msg,
'(a,i6,a,i6,a,i6)')
'time is negative. days=',days_new,
' seconds=',seconds_new,
' ticks=',ticks_new
315 time_out%days = days_new
316 time_out%seconds = seconds_new
317 time_out%ticks = ticks_new
325 function set_time_i(seconds, days, ticks, err_msg)
327 integer,
intent(in) :: seconds
328 integer,
intent(in),
optional :: days, ticks
329 character(len=*),
intent(out),
optional :: err_msg
330 character(len=128) :: err_msg_local
331 integer :: odays, oticks
335 odays = 0;
if(
present(days)) odays = days
336 oticks = 0;
if(
present(ticks)) oticks = ticks
337 if(
present(err_msg)) err_msg =
'' 340 if(
error_handler(
'function set_time_i', trim(err_msg_local), err_msg))
return 346 function set_time_c(string, err_msg, allow_rounding)
349 character(len=*),
intent(in) ::
string 350 character(len=*),
intent(out),
optional :: err_msg
351 logical,
intent(in),
optional :: allow_rounding
353 character(len=4) :: formt=
'(i )' 354 integer :: i1, i2, i3, day, second, tick, nsps
355 character(len=32) :: string_sifted_left
356 character(len=128) :: err_msg_local
357 logical :: allow_rounding_local
360 if(
present(err_msg)) err_msg =
'' 361 allow_rounding_local=.true.;
if(
present(allow_rounding)) allow_rounding_local=allow_rounding
363 err_msg_local =
'Form of character time stamp is incorrect. The character time stamp is: '//trim(
string)
365 string_sifted_left = adjustl(
string)
366 i1 = index(trim(string_sifted_left),
' ')
368 if(
error_handler(
'function set_time_c', err_msg_local, err_msg))
return 370 if(index(
string,
'-') /= 0 .or. index(
string,
':') /= 0)
then 371 if(
error_handler(
'function set_time_c', err_msg_local, err_msg))
return 374 i2 = index(trim(string_sifted_left),
'.')
375 i3 = len_trim(
cut0(string_sifted_left))
380 if(
error_handler(
'function set_time_c', err_msg_local, err_msg))
return 383 write(formt(3:3),
'(i1)') i1-1
384 read(string_sifted_left(1:i1-1),formt) day
387 write(formt(3:3),
'(i1)') i3-i1
388 read(string_sifted_left(i1+1:i3),formt) second
396 write(formt(3:3),
'(i1)') nsps
397 read(string_sifted_left(i1+1:i2-1),formt) second
400 if(.not.
get_tick_from_string(string_sifted_left(i2:i3), err_msg_local, allow_rounding_local, tick))
then 401 if(
error_handler(
'function set_time_c', err_msg_local, err_msg))
return 411 if(
error_handler(
'function set_time_c', err_msg_local, err_msg))
return 421 character(len=*),
intent(in) ::
string 422 character(len=*),
intent(out) :: err_msg
423 logical,
intent(in) :: allow_rounding
424 integer,
intent(out) :: tick
426 character(len=4) :: formt=
'(i )' 427 integer :: i3, nspf, fraction, magnitude, tpsfrac
436 write(formt(3:3),
'(i1)') nspf
437 read(
string(2:i3),formt) fraction
438 if(fraction == 0)
then 443 if(allow_rounding)
then 444 tick = nint((
real(tpsfrac)/magnitude))
446 if(modulo(tpsfrac,magnitude) == 0)
then 447 tick = tpsfrac/magnitude
449 write(err_msg,
'(a,i6)')
'Second fraction cannot be exactly represented with ticks. '// &
492 subroutine get_time(Time, seconds, days, ticks, err_msg)
497 integer,
intent(out) :: seconds
498 integer,
intent(out),
optional :: days, ticks
499 character(len=*),
intent(out),
optional :: err_msg
500 character(len=128) :: err_msg_local
503 if(
present(err_msg)) err_msg =
'' 505 seconds = time%seconds
507 if(
present(ticks))
then 510 if(time%ticks /= 0)
then 511 err_msg_local =
'subroutine get_time: ticks must be present when time has a second fraction' 512 if(
error_handler(
'subroutine get_time', err_msg_local, err_msg))
return 516 if (
present(days))
then 520 err_msg_local =
'Integer overflow in seconds. Optional argument days must be present.' 521 if(
error_handler(
'subroutine get_time', err_msg_local, err_msg))
return 574 function increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
580 integer,
intent(in) :: seconds
581 integer,
intent(in),
optional :: days, ticks
582 character(len=*),
intent(out),
optional :: err_msg
583 logical,
intent(in),
optional :: allow_neg_inc
585 integer :: odays, oticks
586 character(len=128) :: err_msg_local
587 logical :: allow_neg_inc_local
589 odays = 0;
if(
present(days)) odays = days
590 oticks = 0;
if(
present(ticks)) oticks = ticks
591 allow_neg_inc_local=.true.;
if(
present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
593 if(.not.allow_neg_inc_local)
then 594 if(seconds < 0 .or. odays < 0 .or. oticks < 0)
then 595 write(err_msg_local,10) seconds, odays, oticks
596 10
format(
'One or more time increments are negative: seconds=',i6,
' days=',i6,
' ticks=',i6)
597 if(
error_handler(
'function increment_time', err_msg_local, err_msg))
return 602 if(
error_handler(
'function increment_time', err_msg_local, err_msg))
return 615 integer,
intent(in) :: seconds, days, ticks
617 character(len=*),
intent(out) :: err_msg
620 if(days >= huge(days) - time_in%days)
then 621 err_msg =
'Integer overflow in days in increment_time' 625 if(seconds >= huge(seconds) - time_in%seconds)
then 626 err_msg =
'Integer overflow in seconds in increment_time' 678 function decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
684 integer,
intent(in) :: seconds
685 integer,
intent(in),
optional :: days, ticks
686 character(len=*),
intent(out),
optional :: err_msg
687 logical,
intent(in),
optional :: allow_neg_inc
689 integer :: odays, oticks
690 character(len=128) :: err_msg_local
691 logical :: allow_neg_inc_local
693 odays = 0;
if (
present(days)) odays = days
694 oticks = 0;
if (
present(ticks)) oticks = ticks
695 allow_neg_inc_local=.true.;
if(
present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
697 if(.not.allow_neg_inc_local)
then 698 if(seconds < 0 .or. odays < 0 .or. oticks < 0)
then 699 write(err_msg_local,10) seconds,odays,oticks
700 10
format(
'One or more time increments are negative: seconds=',i6,
' days=',i6,
' ticks=',i6)
701 if(
error_handler(
'function decrement_time', err_msg_local, err_msg))
return 706 if(
error_handler(
'function decrement_time', err_msg_local, err_msg))
return 734 function time_gt(time1, time2)
739 type(
time_type),
intent(in) :: time1, time2
741 time_gt = (time1%days > time2%days)
742 if(time1%days == time2%days)
then 743 if(time1%seconds == time2%seconds)
then 744 time_gt = (time1%ticks > time2%ticks)
746 time_gt = (time1%seconds > time2%seconds)
776 function time_ge(time1, time2)
781 type(
time_type),
intent(in) :: time1, time2
783 time_ge = (time_gt(time1, time2) .or. time_eq(time1, time2))
811 function time_lt(time1, time2)
816 type(
time_type),
intent(in) :: time1, time2
818 time_lt = (time1%days < time2%days)
819 if(time1%days == time2%days)
then 820 if(time1%seconds == time2%seconds)
then 821 time_lt = (time1%ticks < time2%ticks)
823 time_lt = (time1%seconds < time2%seconds)
852 function time_le(time1, time2)
857 type(
time_type),
intent(in) :: time1, time2
859 time_le = (time_lt(time1, time2) .or. time_eq(time1, time2))
887 function time_eq(time1, time2)
892 type(
time_type),
intent(in) :: time1, time2
896 time_eq = (time1%seconds == time2%seconds .and. time1%days == time2%days &
897 .and. time1%ticks == time2%ticks)
925 function time_ne(time1, time2)
930 type(
time_type),
intent(in) :: time1, time2
932 time_ne = (.not. time_eq(time1, time2))
960 function time_plus(time1, time2)
965 type(
time_type),
intent(in) :: time1, time2
969 time_plus =
increment_time(time1, time2%seconds, time2%days, time2%ticks)
971 end function time_plus
1001 function time_minus(time1, time2)
1007 type(
time_type),
intent(in) :: time1, time2
1011 if(time1 > time2)
then 1012 time_minus =
decrement_time(time1, time2%seconds, time2%days, time2%ticks)
1014 time_minus =
decrement_time(time2, time1%seconds, time1%days, time1%ticks)
1017 end function time_minus
1043 function time_scalar_mult(time, n)
1049 integer,
intent(in) :: n
1050 integer :: days, seconds, ticks, num_sec
1051 double precision :: sec_prod, tick_prod
1060 tick_prod = dble(time%ticks) * dble(n)
1062 sec_prod = dble(time%seconds) * dble(n) + num_sec
1070 if(sec_prod /= 0.0)
then 1071 if(log10(sec_prod) > precision(sec_prod) - 3)
call error_mesg(
'time_scalar_mult', &
1072 'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',fatal)
1078 time_scalar_mult =
set_time(seconds, time%days * n + days, ticks)
1080 end function time_scalar_mult
1109 integer,
intent(in) :: n
1145 type(
time_type),
intent(in) :: time1, time2
1146 double precision :: d1, d2
1159 call error_mesg(
'time_divide',
' quotient error :: notify developer',fatal)
1188 function time_real_divide(time1, time2)
1192 double precision :: time_real_divide
1193 type(
time_type),
intent(in) :: time1, time2
1194 double precision :: d1, d2
1202 time_real_divide = d1 / d2
1204 end function time_real_divide
1229 subroutine time_assignment(time1, time2)
1230 type(time_type),
intent(out) :: time1
1231 type(time_type),
intent(in) :: time2
1232 time1%seconds = time2%seconds
1233 time1%days = time2%days
1234 time1%ticks = time2%ticks
1235 end subroutine time_assignment
1293 real,
intent(in) :: x
1294 character(len=*),
intent(out),
optional :: err_msg
1295 integer :: seconds, days, ticks
1297 character(len=128) :: err_msg_local
1301 days = floor(x/86400.)
1302 seconds = int(x - 86400.*days)
1303 real_ticks = x - int(x)
1306 if(
error_handler(
'function real_to_time_type', err_msg_local, err_msg))
return 1335 function time_scalar_divide(time, n)
1341 integer,
intent(in) :: n
1342 double precision :: d, div, dseconds_per_day, dticks_per_second
1343 integer :: days, seconds, ticks
1345 character(len=128) tmp1,tmp2
1351 d = time%days*dseconds_per_day*dticks_per_second + dble(time%seconds)*dticks_per_second + dble(time%ticks)
1354 days = div/(dseconds_per_day*dticks_per_second)
1355 seconds = div/dticks_per_second - days*dseconds_per_day
1356 ticks = div - (days*dseconds_per_day + dble(seconds))*dticks_per_second
1357 time_scalar_divide =
set_time(seconds, days, ticks)
1360 prod1 = n * time_scalar_divide
1361 prod2 = n * (
increment_time(time_scalar_divide, days=0, seconds=0, ticks=1))
1362 if(prod1 > time .or. prod2 <= time)
then 1363 call get_time(time, seconds, days, ticks)
1364 write(tmp1,20) days,seconds,ticks
1365 call get_time(time_scalar_divide, seconds, days, ticks)
1366 write(tmp2,30) n,days,seconds,ticks
1367 ltmp =
error_handler(
'time_scalar_divide',
' quotient error:'//trim(tmp1)//trim(tmp2))
1368 20
format(
'time=',i7,
' days, ',i6,
' seconds, ',i6,
' ticks')
1369 30
format(
' time divided by',i6,
'=',i7,
' days, ',i6,
' seconds, ',i6,
' ticks')
1372 end function time_scalar_divide
1411 function interval_alarm(time, time_interval, alarm, alarm_interval)
1421 type(
time_type),
intent(in) :: time, time_interval, alarm_interval
1424 if((alarm - time) <= (time_interval / 2))
then 1426 alarm = alarm + alarm_interval
1464 function repeat_alarm(time, alarm_frequency, alarm_length)
1474 type(
time_type),
intent(in) :: time, alarm_frequency, alarm_length
1477 prev = (time / alarm_frequency) * alarm_frequency
1478 next = prev + alarm_frequency
1479 if(time - prev <= alarm_length / 2 .or. next - time <= alarm_length / 2)
then 1520 integer,
intent(in) :: type
1521 character(len=*),
intent(out),
optional :: err_msg
1522 integer :: iday, days_this_month, year, month, day
1524 character(len=256) :: err_msg_local
1528 if(
present(err_msg)) err_msg =
'' 1530 if(
type < 0 .or. type >
max_type)
then 1531 err_msg_local =
'Illegal calendar type' 1532 if(
error_handler(
'subroutine set_calendar_type', err_msg_local, err_msg))
return 1536 err_msg_local =
'Only calendar type NO_CALENDAR is allowed when seconds_per_day is not 86400.'// &
1538 write(err_msg_local(len_trim(err_msg_local)+1:len_trim(err_msg_local)+8),
'(i8)')
seconds_per_day 1539 if(
error_handler(
'subroutine set_calendar_type', err_msg_local, err_msg))
return 1551 if(leap .and. month ==2) days_this_month = 29
1552 do day=1,days_this_month
1555 coded_date(iday) = day + 32*(month + 16*year)
1603 integer,
intent(in) :: tps
1665 subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg)
1670 integer,
intent(out) :: second, minute, hour, day, month, year
1671 integer,
intent(out),
optional :: tick
1672 character(len=*),
intent(out),
optional :: err_msg
1673 character(len=128) :: err_msg_local
1677 if(
present(err_msg)) err_msg =
'' 1681 call get_date_thirty (time, year, month, day, hour, minute, second, tick1)
1689 err_msg_local =
'Cannot produce a date when the calendar type is NO_CALENDAR' 1690 if(
error_handler(
'subroutine get_date', err_msg_local, err_msg))
return 1692 err_msg_local =
'Invalid calendar type' 1693 if(
error_handler(
'subroutine get_date', err_msg_local, err_msg))
return 1696 if(
present(tick))
then 1700 err_msg_local =
'tick must be present when time has a second fraction' 1701 if(
error_handler(
'subroutine get_date', err_msg_local, err_msg))
return 1713 type(time_type),
intent(in) :: time
1714 integer,
intent(out) :: year, month, day, hour, minute, second
1715 integer,
intent(out) :: tick
1716 integer :: iday, isec
1718 if(time%seconds >= 86400)
then 1719 call error_mesg(
'get_date',.ge.
'Time%seconds 86400 in subroutine get_date_gregorian',fatal)
1731 hour = time%seconds / 3600
1732 isec = time%seconds - 3600*hour
1734 second = isec - 60*minute
1740 function cut0(string)
1742 character(len=*),
intent(in) ::
string 1748 if(ichar(
string(i:i)) == 0 )
then 1762 type(time_type),
intent(in) :: time
1763 integer,
intent(out) :: second, minute, hour, day, month, year
1764 integer,
intent(out) :: tick
1765 integer :: m, t, nfour, nex, days_this_month
1769 nfour = time%days / (4 * 365 + 1)
1770 day = modulo(time%days, (4 * 365 + 1))
1778 day=modulo(day, 365) + 1
1784 year = 1 + 4 * nfour + nex
1790 if(leap .and. m == 2) days_this_month = 29
1791 if(day <= days_this_month)
exit 1792 day = day - days_this_month
1797 hour = t / (60 * 60)
1798 t = t - hour * (60 * 60)
1800 second = t - 60 * minute
1805 subroutine get_date_julian(time, year, month, day, hour, minute, second)
1811 integer,
intent(out) :: second, minute, hour, day, month, year
1820 subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
1825 type(time_type),
intent(in) :: time
1826 integer,
intent(out) :: second, minute, hour, day, month, year
1827 integer,
intent(out) :: tick
1828 integer :: t, dmonth, dyear
1831 dyear = t / (30 * 12)
1833 t = t - dyear * (30 * 12)
1836 day = t -dmonth * 30 + 1
1839 hour = t / (60 * 60)
1840 t = t - hour * (60 * 60)
1842 second = t - 60 * minute
1852 type(time_type),
intent(in) :: time
1853 integer,
intent(out) :: second, minute, hour, day, month, year
1854 integer,
intent(out) :: tick
1858 year = time%days / 365 + 1
1859 day = modulo(time%days, 365) + 1
1870 hour = t / (60 * 60)
1871 t = t - hour * (60 * 60)
1873 second = t - 60 * minute
1885 integer,
intent(out) :: second, minute, hour, day, month, year
1945 function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1953 integer,
intent(in) :: year, month, day, hour, minute, second, tick
1955 character(len=*),
intent(out) :: err_msg
1971 err_msg =
'Cannot produce a date when calendar type is NO_CALENDAR' 1974 err_msg =
'Invalid calendar type' 1982 function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
1984 integer,
intent(in) :: day, month, year
1985 integer,
intent(in),
optional :: second, minute, hour, tick
1986 character(len=*),
intent(out),
optional :: err_msg
1987 integer :: osecond, ominute, ohour, otick
1988 character(len=128) :: err_msg_local
1991 if(
present(err_msg)) err_msg =
'' 1994 osecond = 0;
if(
present(second)) osecond = second
1995 ominute = 0;
if(
present(minute)) ominute = minute
1996 ohour = 0;
if(
present(hour)) ohour = hour
1997 otick = 0;
if(
present(tick)) otick = tick
2000 if(
error_handler(
'function set_date_i', err_msg_local, err_msg))
return 2006 function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
2028 character(len=*),
intent(in) ::
string 2029 logical,
intent(in),
optional :: zero_year_warning
2030 character(len=*),
intent(out),
optional :: err_msg
2031 logical,
intent(in),
optional :: allow_rounding
2032 character(len=4) :: formt=
'(i )' 2033 logical :: correct_form, zero_year_warning_local, allow_rounding_local
2034 integer :: i1, i2, i3, i4, i5, i6, i7
2035 character(len=32) :: string_sifted_left
2036 integer :: year, month, day, hour, minute, second, tick
2037 character(len=128) :: err_msg_local
2040 if(
present(err_msg)) err_msg =
'' 2041 if(
present(zero_year_warning))
then 2042 zero_year_warning_local = zero_year_warning
2044 zero_year_warning_local = .true.
2046 if(
present(allow_rounding))
then 2047 allow_rounding_local = allow_rounding
2049 allow_rounding_local = .true.
2052 string_sifted_left = adjustl(
string)
2053 i1 = index(string_sifted_left,
'-')
2054 i2 = index(string_sifted_left,
'-',back=.true.)
2055 i3 = index(string_sifted_left,
':')
2056 i4 = index(string_sifted_left,
':',back=.true.)
2057 i5 = len_trim(
cut0(string_sifted_left))
2058 i6 = index(string_sifted_left,
'.',back=.true.)
2059 correct_form = (i1 > 1)
2060 correct_form = correct_form .and. (i2-i1 == 2 .or. i2-i1 == 3)
2061 if(.not.correct_form)
then 2062 err_msg_local =
'Form of character time stamp is incorrect. The character time stamp is: '//trim(
string)
2063 if(
error_handler(
'function set_date_c', err_msg_local, err_msg))
return 2065 write(formt(3:3),
'(i1)') i1-1
2066 read(string_sifted_left(1:i1-1),formt) year
2069 if(zero_year_warning_local)
then 2070 call error_mesg(
'set_date_c',
'Year zero is invalid. Resetting year to 1', warning)
2073 write(formt(3:3),
'(i1)') i2-i1-1
2074 read(string_sifted_left(i1+1:i2-1),formt) month
2076 read(string_sifted_left(i2+1:i7),
'(i2)') day
2088 read(string_sifted_left(i5-1:i5),
'(i2)') hour
2090 else if(i3 == i4)
then 2092 read(string_sifted_left(i3-2:i3-1),
'(i2)') hour
2093 write(formt(3:3),
'(i1)') i5-i3
2094 read(string_sifted_left(i3+1:i5),formt) minute
2099 read(string_sifted_left(i3-2:i3-1),
'(i2)') hour
2100 write(formt(3:3),
'(i1)') i4-i3-1
2101 read(string_sifted_left(i3+1:i4-1),formt) minute
2102 write(formt(3:3),
'(i1)') i5-i4
2105 read(string_sifted_left(i4+1:i5),formt) second
2108 read(string_sifted_left(i4+1:i6-1),formt) second
2109 if(.not.
get_tick_from_string(string_sifted_left(i6:i5), err_msg_local, allow_rounding_local, tick))
then 2110 if(
error_handler(
'function set_date_c', err_msg_local, err_msg))
return 2121 if(
error_handler(
'function set_date_c', err_msg_local, err_msg))
return 2127 function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2132 integer,
intent(in) :: year, month, day, hour, minute, second, tick
2133 type(
time_type),
intent(out) :: time_out
2134 character(len=*),
intent(out) :: err_msg
2135 integer :: yr1, day1
2137 if( .not.
valid_increments(year,month,day,hour,minute,second,tick,err_msg) )
then 2142 time_out%seconds = second + 60*(minute + 60*hour)
2145 if(yr1 == 0) yr1 = 400
2154 time_out%ticks = tick
2167 integer,
intent(in) :: year, month, day, hour, minute, second, tick
2168 type(
time_type),
intent(out) :: time_out
2169 character(len=*),
intent(out) :: err_msg
2170 integer :: ndays, m, nleapyr
2173 if( .not.
valid_increments(year,month,day,hour,minute,second,tick,err_msg) )
then 2185 leap = (modulo(year,4) == 0)
2187 nleapyr = (year - 1) / 4
2190 if(month == 2 .and. (day > 29 .or. ((.not. leap) .and. day > 28)))
then 2199 if(leap .and. m == 2) ndays = ndays + 1
2202 time_out%seconds = second + 60 * (minute + 60 * hour)
2203 time_out%days = day -1 + ndays + 365*(year - nleapyr - 1) + 366*(nleapyr)
2204 time_out%ticks = tick
2217 integer,
intent(in) :: year, month, day, hour, minute, second
2218 character(len=128) :: err_msg
2221 call error_mesg(
'set_date_julian',trim(err_msg),fatal)
2227 function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2232 integer,
intent(in) :: year, month, day, hour, minute, second, tick
2233 type(
time_type),
intent(out) :: time_out
2234 character(len=*),
intent(out) :: err_msg
2236 if( .not.
valid_increments(year,month,day,hour,minute,second,tick,err_msg) )
then 2247 time_out%days = (day - 1) + 30 * ((month - 1) + 12 * (year - 1))
2248 time_out%seconds = second + 60 * (minute + 60 * hour)
2249 time_out%ticks = tick
2262 integer,
intent(in) :: year, month, day, hour, minute, second, tick
2263 type(
time_type),
intent(out) :: time_out
2264 character(len=*),
intent(out) :: err_msg
2267 if( .not.
valid_increments(year,month,day,hour,minute,second,tick,err_msg) )
then 2284 time_out =
set_time(second + 60 * (minute + 60 * hour), day -1 + ndays + 365 * (year - 1), tick)
2297 integer,
intent(in) :: year, month, day, hour, minute, second
2298 character(len=128) :: err_msg
2301 call error_mesg(
'set_date_no_leap',trim(err_msg),fatal)
2308 function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
2310 integer,
intent(in) :: year, month, day, hour, minute, second, tick
2311 character(len=128),
intent(out) :: err_msg
2317 if(second > 59 .or. second < 0 .or. minute > 59 .or. minute < 0 &
2318 .or. hour > 23 .or. hour < 0 .or. day > 31 .or. day < 1 &
2319 .or. month > 12 .or. month < 1 .or. year < 1)
then 2325 write(err_msg,
'(a,i6)')
'Invalid number of ticks. tick=',tick
2335 integer,
intent(in) :: year, month, day
2336 integer,
intent(in) :: hour, minute, second
2339 10
format(i4.4,
'-', i2.2,
'-', i2.2,
' ', i2.2,
':', i2.2,
':', i2.2)
2394 function increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
2408 integer,
intent(in),
optional :: years, months, days, hours, minutes, seconds, ticks
2409 character(len=*),
intent(out),
optional :: err_msg
2410 logical,
intent(in),
optional :: allow_neg_inc
2412 integer :: oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2413 character(len=128) :: err_msg_local
2414 logical :: allow_neg_inc_local
2417 if(
present(err_msg)) err_msg =
'' 2420 oseconds = 0;
if(
present(seconds)) oseconds = seconds
2421 ominutes = 0;
if(
present(minutes)) ominutes = minutes
2422 ohours = 0;
if(
present(hours)) ohours = hours
2423 odays = 0;
if(
present(days)) odays = days
2424 omonths = 0;
if(
present(months)) omonths = months
2425 oyears = 0;
if(
present(years)) oyears = years
2426 oticks = 0;
if(
present(ticks)) oticks = ticks
2427 allow_neg_inc_local=.true.;
if(
present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
2429 if(.not.allow_neg_inc_local)
then 2430 if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0)
then 2431 write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2432 if(
error_handler(
'function increment_time', err_msg_local, err_msg))
return 2435 10
format(
'One or more time increments are negative: '// &
2436 'years=',i6,
' months=',i6,
' days=',i6,
' hours=',i6,
' minutes=',i6,
' seconds=',i6,
' ticks=',i6)
2439 time, oyears, omonths, odays, ohours, ominutes, oseconds, oticks,
increment_date, err_msg_local))
then 2440 if(
error_handler(
'function increment_date', err_msg_local, err_msg))
return 2449 function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
2465 integer,
intent(in) :: years, months, days, hours, minutes, seconds, ticks
2466 type(
time_type),
intent(out) :: time_out
2467 character(len=*),
intent(out) :: err_msg
2468 integer :: cyear , cmonth , cday , chour , cminute , csecond , ctick
2469 logical :: mode_1, mode_2
2474 mode_1 = days /= 0 .or. hours /= 0 .or. minutes /= 0 .or. seconds /= 0 .or. ticks /= 0
2475 mode_2 = years /= 0 .or. months /= 0
2477 if(.not.mode_1 .and. .not.mode_2)
then 2483 if(mode_1 .and. mode_2)
then 2484 err_msg =
'years and/or months must not be incremented with other time units' 2490 csecond = seconds + 60 * (minutes + 60 * hours)
2498 call get_date_thirty (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2506 err_msg =
'Cannot increment a date when the calendar type is NO_CALENDAR' 2510 err_msg =
'Invalid calendar type' 2516 cmonth = cmonth + months
2519 cyear = cyear + floor((cmonth-1)/12.)
2520 cmonth = modulo((cmonth-1),12) + 1
2523 cyear = cyear + years
2588 function decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
2592 integer,
intent(in),
optional :: seconds, minutes, hours, days, months, years, ticks
2593 character(len=*),
intent(out),
optional :: err_msg
2594 logical,
intent(in),
optional :: allow_neg_inc
2596 integer :: oseconds, ominutes, ohours, odays, omonths, oyears, oticks
2597 character(len=128) :: err_msg_local
2598 logical :: allow_neg_inc_local
2600 if(
present(err_msg)) err_msg =
'' 2603 oseconds = 0;
if(
present(seconds)) oseconds = seconds
2604 ominutes = 0;
if(
present(minutes)) ominutes = minutes
2605 ohours = 0;
if(
present(hours)) ohours = hours
2606 odays = 0;
if(
present(days)) odays = days
2607 omonths = 0;
if(
present(months)) omonths = months
2608 oyears = 0;
if(
present(years)) oyears = years
2609 oticks = 0;
if(
present(ticks)) oticks = ticks
2610 allow_neg_inc_local=.true.;
if(
present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
2612 if(.not.allow_neg_inc_local)
then 2613 if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0)
then 2614 write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2615 if(
error_handler(
'function decrement_date', err_msg_local, err_msg))
return 2618 10
format(
'One or more time increments are negative: '// &
2619 'years=',i6,
' months=',i6,
' days=',i6,
' hours=',i6,
' minutes=',i6,
' seconds=',i6,
' ticks=',i6)
2622 time, -oyears, -omonths, -odays, -ohours, -ominutes, -oseconds, -oticks,
decrement_date, err_msg_local))
then 2623 if(
error_handler(
'function decrement_date', err_msg_local, err_msg))
return 2656 character(len=*),
intent(out),
optional :: err_msg
2659 if(
present(err_msg)) err_msg =
'' 2672 'days_in_month makes no sense when the calendar type is NO_CALENDAR', err_msg))
return 2674 if(
error_handler(
'function days_in_month',
'Invalid calendar type', err_msg))
return 2687 integer :: year, month, day, hour, minute, second, ticks
2702 integer :: year, month, day, hour, minute, second, ticks
2730 integer :: year, month, day, hour, minute, second, ticks
2763 character(len=*),
intent(out),
optional :: err_msg
2766 if(
present(err_msg)) err_msg=
'' 2778 if(
error_handler(
'function leap_year',
'Invalid calendar type in leap_year', err_msg))
return 2791 integer :: seconds, minutes, hours, day, month, year
2793 call get_date(time, year, month, day, hours, minutes, seconds)
2802 integer,
intent(in) :: year
2818 integer :: seconds, minutes, hours, day, month, year
2820 call get_date(time, year, month, day, hours, minutes, seconds)
2883 call error_mesg(
'length_of_year',
'Invalid calendar type in length_of_year',fatal)
2903 integer :: days, seconds
2942 integer :: second, minute, hour, day, month, year
2945 call get_date(time,year,month,day,hour,minute,second)
2987 call error_mesg(
'days_in_year',
'Invalid calendar type in days_in_year',fatal)
3073 integer,
intent(in) :: n
3074 character (len = 9),
dimension(12) :: months = (/
'January ',
'February ', &
3075 'March ',
'April ',
'May ',
'June ',
'July ', &
3076 'August ',
'September',
'October ',
'November ',
'December '/)
3080 if(n < 1 .or. n > 12)
call error_mesg(
'month_name',
'Illegal month index',fatal)
3097 character(len=*),
intent(in) :: routine, err_msg_local
3098 character(len=*),
intent(out),
optional :: err_msg
3101 if(
present(err_msg))
then 3102 err_msg = err_msg_local
3105 call error_mesg(trim(routine),trim(err_msg_local),fatal)
3127 call write_version_number(
"TIME_MANAGER_MOD", version)
3153 character (len=*),
intent(in),
optional :: str
3154 integer ,
intent(in),
optional :: unit
3155 integer :: s,d,ticks, ns,nd,nt, unit_in
3156 character(len=19) :: fmt
3162 if (
present(unit)) unit_in = unit
3168 nd = int(log10(
real(
max(1,d))))+1
3169 ns = int(log10(
real(
max(1,s))))+1
3170 nt = int(log10(
real(
max(1,ticks))))+1
3171 write (fmt,10) nd, ns, nt
3172 10
format (
'(a,i',i2.2,
',a,i',i2.2,
',a,i',i2.2,
')')
3174 if (
present(str))
then 3175 write (unit_in,fmt) trim(str)//
' day=', d,
', sec=', s,
', ticks=', ticks
3177 write (unit_in,fmt)
'TIME: day=', d,
', sec=', s,
', ticks=', ticks
3205 character (len=*),
intent(in),
optional :: str
3206 integer ,
intent(in),
optional :: unit
3207 integer :: y,mo,d,h,m,s, unit_in
3208 character(len=9) :: mon
3214 if (
present(unit)) unit_in = unit
3218 if (
present(str))
then 3219 write (unit_in,10) trim(str)//
' ', y,mon(1:3),
' ',d,
' ',h,
':',m,
':',s
3221 write (unit_in,10)
'DATE: ', y,mon(1:3),
' ',d,
' ',h,
':',m,
':',s
3223 10
format (a,i4,1x,a3,4(a1,i2.2))
3255 integer,
intent(in) :: ncal
3256 character(len=*),
intent(out),
optional :: err_msg
3258 character(len=128) :: err_msg_local
3262 if(
present(err_msg)) err_msg =
'' 3268 else if(ncal ==
julian)
then 3272 else if(ncal ==
noleap)
then 3275 write(err_msg_local,
'(a,i4,a)')
'calendar type=',ncal,
' is invalid.' 3276 if(
error_handler(
'function valid_calendar_types', err_msg_local, err_msg))
return 3286 character(len=*),
intent(out),
optional :: err_msg
3287 character(len=128) :: err_msg_local
3289 integer :: yr,mon,day,hr,
min,sec
3291 if(
present(err_msg)) err_msg =
'' 3293 if (yr <= 9999)
then 3294 write(
date_to_string,
'(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr,
min, sec
3296 write(err_msg_local,
'(a,i4.4,a)')
'year = ', yr,
' should be less than 10000' 3297 if(
error_handler(
'function date_to_string', err_msg_local, err_msg))
return 3307 character(len=:),
allocatable :: terr
3309 allocate (
character(len=10) :: terr)
3311 write (terr,
'(I0)') t%days
3425 #ifdef test_time_manager 3437 use time_manager_mod,
only:
operator(-),
operator(+),
operator(*),
operator(/), &
3438 operator(>),
operator(>=),
operator(==),
operator(/=), &
3439 operator(<),
operator(<=),
operator(//),
assignment(=)
3445 integer :: yr, mo, day, hr,
min, sec, ticks
3446 integer :: year, month, dday, days_this_month
3447 integer ::
days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
3449 integer :: nr, icode, nmlunit, ierr, io, nn, errunit, outunit
3450 character(len=256) :: err_msg, char_date
3451 character(len=8),
allocatable,
dimension(:) :: test_time
3452 character(len=23),
allocatable,
dimension(:) :: test_date
3453 character(len=8) :: test_name
3455 logical :: test1 =.true.,test2 =.true.,test3 =.true.,test4 =.true.,test5 =.true.,test6 =.true.,test7 =.true.,test8 =.true.
3456 logical :: test9 =.true.,test10=.true.,test11=.true.,test12=.true.,test13=.true.,test14=.true.,test15=.true.,test16=.true.
3457 logical :: test17=.true.,test18=.true.,test19=.true.
3459 namelist / test_nml / test1 ,test2 ,test3 ,test4 ,test5 ,test6 ,test7 ,test8, &
3460 test9 ,test10,test11,test12,test13,test14,test15,test16, &
3461 test17,test18,test19
3466 #ifdef INTERNAL_FILE_NML 3470 nmlunit = open_namelist_file()
3472 do while (ierr /= 0)
3473 read(nmlunit, nml=test_nml, iostat=io, end=12)
3476 12
call close_file (nmlunit)
3479 outunit = open_file(file=
'test_time_manager.out', form=
'formatted', action=
'write')
3487 write(outunit,
'(/,a)')
'################################# test1 #################################' 3489 call get_time(time, sec, day, ticks)
3490 write(outunit,
'(a,i2,a,i8,a,i2)')
' test1.1: days=',day,
' seconds=',sec,
' ticks=',ticks
3492 write(outunit,
'(a,i2,a,i8)')
' test1.2: days=',day,
' seconds=',sec
3494 write(outunit,
'(a,i8)')
' test1.2: seconds=',sec
3500 write(outunit,
'(/,a)')
'################################# test2 #################################' 3501 time =
set_time(seconds=2, days=1, ticks=5)
3502 call get_time(time, sec, day, ticks)
3503 write(outunit,
'(a,i2,a,i6,a,i2)')
' test2.1: days=',day,
' seconds=',sec,
' ticks=',ticks
3504 call get_time(time, sec, ticks=ticks)
3505 write(outunit,
'(a,i6,a,i2)')
' test2.2: seconds=',sec,
' ticks=',ticks
3506 call get_time(time, sec, day, err_msg=err_msg)
3507 if(err_msg /=
'')
then 3508 write(outunit,
'(a)')
' test2.3 successful: '//trim(err_msg)
3510 write(outunit,
'(a,i2,a,i8)')
' test2.3 fails. days=',day,
' seconds=',sec
3512 call get_time(time, sec, err_msg=err_msg)
3513 if(err_msg /=
'')
then 3514 write(outunit,
'(a)')
' test2.4 successful: '//trim(err_msg)
3516 write(outunit,
'(a,i8)')
' test2.4 fails. seconds=',sec
3528 write(outunit,
'(/,a)')
'################################# test3 #################################' 3538 call print_time(25000*
set_time(seconds=86399, days=0, ticks=0),
'test3.4:', unit=outunit)
3541 call print_time(
set_time(seconds=0, days=60000, ticks=2)/2,
'test3.5:', unit=outunit)
3545 write(outunit,
'("test3.6: xx=",f15.9)') xx
3549 write(outunit,
'("test3.7: nn=",i6)') nn
3552 if(
set_time(seconds=1, days=1, ticks=2) >
set_time(seconds=1, days=1, ticks=1))
then 3553 write(outunit,
'("test3.8 successful")')
3555 write(outunit,
'("test3.8 fails")')
3557 if(
set_time(seconds=1, days=1, ticks=2) >
set_time(seconds=1, days=1, ticks=2))
then 3558 write(outunit,
'("test3.9 fails")')
3560 write(outunit,
'("test3.9 successful")')
3564 if(
set_time(seconds=1, days=1, ticks=1) <
set_time(seconds=1, days=1, ticks=2))
then 3565 write(outunit,
'("test3.10 successful")')
3567 write(outunit,
'("test3.10 fails")')
3569 if(
set_time(seconds=1, days=1, ticks=2) <
set_time(seconds=1, days=1, ticks=2))
then 3570 write(outunit,
'("test3.11 fails")')
3572 write(outunit,
'("test3.11 successful")')
3576 if(
set_time(seconds=1, days=1, ticks=1) ==
set_time(seconds=1, days=1, ticks=1))
then 3577 write(outunit,
'("test3.12 successful")')
3579 write(outunit,
'("test3.12 fails")')
3581 if(
set_time(seconds=1, days=1, ticks=1) ==
set_time(seconds=1, days=1, ticks=2))
then 3582 write(outunit,
'("test3.13 fails")')
3584 write(outunit,
'("test3.13 successful")')
3591 write(outunit,
'(/,a)')
'################################# test4 #################################' 3592 test_name =
'test4. ' 3593 allocate(test_time(15))
3594 test_time( 1: 6) = (/
'1 10 ',
'1 10. ',
'1 10.000',
'1 0.0 ',
'1 .000',
'1 . '/)
3595 test_time( 7: 9) = (/
'1 10.20 ',
'1 10.300',
'1 0.40 '/)
3596 test_time(10:15) = (/
'1 .510',
'2 .50001',
'1.0 10.2',
'10.30000',
'10-0.40 ',
'10:1.510'/)
3598 write(test_name(7:8),
'(i2.2)') nr
3599 time =
set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
3600 if(err_msg ==
'')
then 3601 call print_time(time, test_name//
':', unit=outunit)
3603 write(outunit,
'(a)') test_name//
' fails: '//trim(err_msg)
3607 test_time(1:6) = (/
'1 .510',
'2 .50001',
'1.0 10.2',
'10.30000',
'10-0.40 ',
'10:1.510'/)
3609 write(test_name(7:8),
'(i2.2)') nr
3610 time =
set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
3611 if(err_msg /=
'')
then 3612 write(outunit,
'(a)') test_name//
' successful: '//trim(err_msg)
3614 write(outunit,
'(a)') test_name//
' fails ' 3623 write(outunit,
'(/,a)')
'################################# test5 #################################' 3628 time =
set_date(1980, 1, 2, tick=10, err_msg=err_msg)
3629 if(err_msg ==
'')
then 3630 write(outunit,
'(a)')
' test5.4 fails' 3632 write(outunit,
'(a)')
' test5.4 successful: '//trim(err_msg)
3639 write(outunit,
'(/,a)')
'################################# test6 #################################' 3640 test_name =
'test6. ' 3642 allocate(test_date(6))
3643 test_date(1:3) = (/
' 1980-12-30 01:01:11 ',
' 1980-12-30 01:01:11.50',
' 1980-12-30 01:01:11.55'/)
3644 test_date(4:6) = (/
' 1980-12-30 01:01:11.96',
' 1980-1-3 1:1:11 ',
' 1980-1-3 1:1:11.99 '/)
3646 write(test_name(7:8),
'(i2.2)') nr
3647 time =
set_date(trim(test_date(nr)), err_msg=err_msg, allow_rounding=.true., zero_year_warning=.true.)
3648 if(err_msg ==
'')
then 3649 call print_time(time,test_name//
' successful:', unit=outunit)
3651 write(outunit,
'(a)') test_name//
'fails: '//trim(err_msg)
3656 time =
set_date(
'1900-01-31 00:00:00', err_msg=err_msg)
3657 if(err_msg ==
'')
then 3658 write(outunit,
'(a)')
'test6.8 fails' 3660 write(outunit,
'(a)')
'test6.8 successful '//trim(err_msg)
3663 time =
set_date(
'1901-02-29 00:00:00', err_msg=err_msg)
3664 if(err_msg ==
'')
then 3665 write(outunit,
'(a)')
'test6.9 fails' 3667 write(outunit,
'(a)')
'test6.9 successful '//trim(err_msg)
3674 write(outunit,
'(/,a)')
'################################# test7 #################################' 3675 char_date =
'1904-01-01 00:00:00' 3676 write(outunit,
'(a)')
' Initial date='//trim(char_date)//
':00' 3679 write(outunit,
'("=================================================================")')
3682 write(outunit,
'(" THIRTY_DAY_MONTHS")')
3686 write(outunit,
'(" NOLEAP")')
3690 write(outunit,
'(" JULIAN")')
3694 write(outunit,
'(" GREGORIAN")')
3699 write(outunit,
'(" test of decrement_date increments: year=",i2," month=",i2)') year,month
3701 if(err_msg /=
'')
then 3702 write(outunit,
'(a)')
'test of decrement_date fails '//trim(err_msg)
3704 call get_date(time2, yr, mo, day, hr,
min, sec, ticks)
3705 write(outunit,20) yr, mo, day, hr,
min, sec, ticks
3709 time1 =
set_date(1, 1, 2, 1, 1, 1, 1, err_msg)
3710 write(outunit,
'(" Initial date = 01-01-02 01:01:01:01")')
3712 day = modulo(icode/81,3) - 1
3713 hr = modulo(icode/27,3) - 1
3714 min = modulo(icode/9, 3) - 1
3715 sec = modulo(icode/3, 3) - 1
3716 ticks = modulo(icode ,3) - 1
3717 write(outunit,11) day, hr,
min, sec, ticks
3719 call get_date(time2, yr, mo, day, hr,
min, sec, ticks)
3720 write(outunit,20) yr, mo, day, hr,
min, sec, ticks
3725 11
format(
' test of increment_date increments: day=',i2,
' hr=',i2,
' min=',i2,
' sec=',i2,
' ticks=',i2)
3726 20
format(
' time=',i4.4,
'-', i2.2,
'-', i2.2,
' ', i2.2,
':', i2.2,
':', i2.2,
':', i2.2)
3731 write(outunit,
'(/,a)')
'################################# test8 #################################' 3733 time =
set_date(
'1904-02-29 00:00:00', err_msg=err_msg)
3734 if(err_msg ==
'')
then 3735 call print_time(time,
'test8.1 successful', unit=outunit)
3737 write(outunit,
'(a)')
'test8.1 fails: '//trim(err_msg)
3741 time =
set_date(
'1904-02-29 00:00:00', err_msg=err_msg)
3742 if(err_msg ==
'')
then 3743 write(outunit,
'(a)')
'test8.2 fails' 3745 write(outunit,
'(a)')
'test8.2 successful: '//trim(err_msg)
3749 time =
set_date(
'1900-02-29 00:00:00', err_msg=err_msg)
3750 if(err_msg ==
'')
then 3751 write(outunit,
'(a)')
'test8.3 fails' 3753 write(outunit,
'(a)')
'test8.3 successful: '//trim(err_msg)
3755 time =
set_date(
'2000-02-29 00:00:00', err_msg=err_msg)
3756 if(err_msg ==
'')
then 3757 write(outunit,
'(a)')
'test8.4 successful' 3759 write(outunit,
'(a)')
'test8.4 fails: '//trim(err_msg)
3763 time =
set_date(
'1900-02-29 00:00:00', err_msg=err_msg)
3764 if(err_msg ==
'')
then 3765 write(outunit,
'(a)')
'test8.5 successful' 3767 write(outunit,
'(a)')
'test8.5 fails: '//trim(err_msg)
3769 time =
set_date(
'1901-02-29 00:00:00', err_msg=err_msg)
3770 if(err_msg ==
'')
then 3771 write(outunit,
'(a)')
'test8.6 fails' 3773 write(outunit,
'(a)')
'test8.6 successful: '//trim(err_msg)
3780 write(outunit,
'(/,a)')
'################################# test9 #################################' 3782 write(outunit,
'(a,i4)')
' test9.1: day=',day
3784 write(outunit,
'(a,i4)')
' test9.2: day=',day
3790 write(outunit,
'(/,a)')
'################################# test10 #################################' 3791 time =
set_time(seconds=2, days=1, ticks=1)
3792 call get_time(time, seconds=sec, days=day, err_msg=err_msg)
3793 if(err_msg ==
'')
then 3794 write(outunit,
'(a)')
'test10.1 fails' 3796 write(outunit,
'(a)')
'test10.1 successful: '//trim(err_msg)
3799 time =
set_time(seconds=2, days=1, ticks=1)
3800 call get_date(time, yr, mo, day, hr,
min, sec, err_msg=err_msg)
3801 if(err_msg ==
'')
then 3802 write(outunit,
'(a)')
'test10.2 fails' 3804 write(outunit,
'(a)')
'test10.2 successful: '//trim(err_msg)
3811 write(outunit,
'(/,a)')
'################################# test11 #################################' 3821 write(outunit,
'(/,a)')
'################################# test12 #################################' 3831 write(outunit,
'(/,a)')
'################################# test13 #################################' 3832 time =
set_time(seconds= 2, days=0, ticks=-21, err_msg=err_msg)
3833 if(err_msg ==
'')
then 3834 write(outunit,
'(a)')
'test13.1 fails' 3836 write(outunit,
'(a)')
'test13.1 successful: '//trim(err_msg)
3843 write(outunit,
'(/,a)')
'################################# test14 #################################' 3844 call print_time(
set_time(seconds=-86399, days=2, ticks=-10),
'test14.1:', unit=outunit)
3845 call print_time(
set_time(seconds=-86390, days=2, ticks=-95),
'test14.2:', unit=outunit)
3846 call print_time(
set_time(seconds= 86400, days=2, ticks= 95),
'test14.3:', unit=outunit)
3852 write(outunit,
'(/,a)')
'################################# test15 #################################' 3856 write(outunit,10)
'GREGORIAN',day
3861 write(outunit,10)
'JULIAN',day
3866 write(outunit,10)
'THIRTY_DAY_MONTHS',day
3871 write(outunit,10)
'NOLEAP',day
3874 10
format(a17,
' Jan 1 year 1 is day=',i6)
3880 write(outunit,
'(/,a)')
'################################# test16 #################################' 3882 time =
set_date(1900, 1, 32, err_msg=err_msg)
3883 if(err_msg ==
'')
then 3884 write(outunit,
'(a)')
'test16.1 fails' 3886 write(outunit,
'(a)')
'test16.1 successful: '//trim(err_msg)
3889 time =
set_date(1900, 4, 31, err_msg=err_msg)
3890 if(err_msg ==
'')
then 3891 write(outunit,
'(a)')
'test16.2 fails' 3893 write(outunit,
'(a)')
'test16.2 successful: '//trim(err_msg)
3896 time =
set_date(1900, 2, 29, err_msg=err_msg)
3897 if(err_msg ==
'')
then 3898 write(outunit,
'(a)')
'test16.3 fails' 3900 write(outunit,
'(a)')
'test16.3 successful: '//trim(err_msg)
3904 time =
set_date(1900, 1, 0, err_msg=err_msg)
3905 if(err_msg ==
'')
then 3906 write(outunit,
'(a)')
'test16.4 fails' 3908 write(outunit,
'(a)')
'test16.4 successful: '//trim(err_msg)
3912 time =
set_date(1900, 0, 1, err_msg=err_msg)
3913 if(err_msg ==
'')
then 3914 write(outunit,
'(a)')
'test16.5 fails' 3916 write(outunit,
'(a)')
'test16.5 successful: '//trim(err_msg)
3919 time =
set_date(1900, 1, 1, tick=11, err_msg=err_msg)
3920 if(err_msg ==
'')
then 3921 write(outunit,
'(a)')
'test16.6 fails' 3923 write(outunit,
'(a)')
'test16.6 successful: '//trim(err_msg)
3927 time =
set_date(1900, 13, 1, err_msg=err_msg)
3928 if(err_msg ==
'')
then 3929 write(outunit,
'(a)')
'test16.7 fails' 3931 write(outunit,
'(a)')
'test16.7 successful: '//trim(err_msg)
3934 time =
set_date(1900, 12, 31, err_msg=err_msg)
3935 if(err_msg ==
'')
then 3936 write(outunit,
'(a)')
'test16.8 fails' 3938 write(outunit,
'(a)')
'test16.8 successful: '//trim(err_msg)
3942 time =
set_date(1900, 4, 31, err_msg=err_msg)
3943 if(err_msg ==
'')
then 3944 write(outunit,
'(a)')
'test16.9 fails' 3946 write(outunit,
'(a)')
'test16.9 successful: '//trim(err_msg)
3954 write(outunit,
'(/,a)')
'################################# test17 #################################' 3955 write(errunit,
'(/,a)')
' =====================================================' 3956 write(errunit,
'(a)')
' Warning: test17 produces voluminous output.' 3957 write(errunit,
'(a)')
' It can be turned off with: &test_nml test17=.false./' 3958 write(errunit,
'(a,/)')
' =====================================================' 3961 leap = mod(year,4) == 0
3962 leap = leap .and. .not.mod(year,100) == 0
3963 leap = leap .or. mod(year,400) == 0
3966 if(leap .and. month == 2) days_this_month = 29
3967 do dday=1,days_this_month
3968 time =
set_date(year, month, dday, 0, 0, 0)
3975 100
format(
'yr=',i4,
' mo=',i2,
' day=',i2,
' leap=',l1,
' days_in_month=',i2,
' days_in_year=',i3)
3980 write(outunit,
'(/,a)')
'################################# test18 #################################' 3994 write(outunit,
'(/,a)')
'################################# test19 #################################' 3997 if(err_msg ==
'')
then 3998 write(outunit,
'(a)')
'test of real_to_time_type fails' 4000 write(outunit,
'(a)')
'test successful: '//trim(err_msg)
4004 write(outunit,
'(/,a)')
'############################################################################'
type(time_type) function, public increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
logical function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
integer function, public get_ticks_per_second()
type(time_type) function, public increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
integer, parameter max_type
integer, parameter, public gregorian
subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)
type(time_type) function, public length_of_year()
logical function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
void error_handler(const char *msg)
type(time_type) function length_of_year_gregorian()
integer, parameter, public noleap
integer function days_in_month_thirty(Time)
type(time_type) function, public set_date_julian(year, month, day, hour, minute, second)
character(len=9) function, public month_name(n)
subroutine, public get_date_no_leap(time, year, month, day, hour, minute, second)
integer function time_divide(time1, time2)
integer, private calendar_type
type(time_type) function length_of_year_julian()
integer, parameter days_in_400_year_period
type(time_type) function length_of_year_no_leap()
logical function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
integer, parameter invalid_date
integer function, public check_nml_error(IOSTAT, NML_NAME)
integer, dimension(days_in_400_year_period) coded_date
integer function days_in_month_gregorian(Time)
logical function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
integer function days_in_year_thirty(Time)
type(time_type) function set_time_c(string, err_msg, allow_rounding)
integer function days_in_year_no_leap(Time)
type(time_type) function length_of_year_thirty()
logical function leap_year_gregorian(Time)
character(len=input_str_length), dimension(:), allocatable, target, public input_nml_file
logical function, public interval_alarm(time, time_interval, alarm, alarm_interval)
subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
subroutine, public set_calendar_type(type, err_msg)
logical function set_time_private(seconds, days, ticks, Time_out, err_msg)
logical function get_tick_from_string(string, err_msg, allow_rounding, tick)
integer function days_in_month_no_leap(Time)
subroutine, public fms_init(localcomm)
integer function, public day_of_year(time)
logical function leap_year_gregorian_int(year)
character(len=15) function, public date_to_string(time, err_msg)
character(len=24) function, public valid_calendar_types(ncal, err_msg)
integer function, public days_in_month(Time, err_msg)
integer, parameter, public julian
subroutine, public time_list_error(T, Terr)
This routine converts the integer tdays to a string.
integer function, public get_calendar_type()
integer, parameter, public thirty_day_months
logical function leap_year_julian(Time)
logical function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
type(time_type) function set_time_i(seconds, days, ticks, err_msg)
type(time_type) function, public set_date_no_leap(year, month, day, hour, minute, second)
subroutine, public time_manager_init()
integer, dimension(400, 12, 31) date_to_day
integer function days_in_year_gregorian(Time)
integer, parameter, public no_calendar
character(len=256) function cut0(string)
integer function days_in_year_julian(Time)
integer, dimension(12), private days_per_month
logical function leap_year_thirty(Time)
type(time_type) function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
logical function, public leap_year(Time, err_msg)
subroutine, public fms_end()
type(time_type) function, public real_to_time_type(x, err_msg)
subroutine, public fms_io_exit()
logical function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
type(time_type) function, public decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
real(double_kind) function, public time_type_to_real(time)
subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)
integer function, public days_in_year(Time)
logical function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
integer function days_in_month_julian(Time)
logical function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)
real, parameter, public seconds_per_day
Seconds in a day [s].
character(len=19) function convert_integer_date_to_char(year, month, day, hour, minute, second)
subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
logical function, public repeat_alarm(time, alarm_frequency, alarm_length)
subroutine, public error_mesg(routine, message, level)
type(time_type) function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
integer, parameter, public invalid_calendar
subroutine, public print_time(Time, str, unit)
subroutine, public constants_init
dummy routine.
subroutine, public get_date_julian(time, year, month, day, hour, minute, second)
type(time_type) function scalar_time_mult(n, time)
type(time_type) function, public decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
subroutine, public print_date(Time, str, unit)
logical function leap_year_no_leap(Time)
logical module_is_initialized
subroutine, public set_ticks_per_second(tps)