FMS  2025.04
Flexible Modeling System
time_manager.F90
1 !***********************************************************************
2 !* Apache License 2.0
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* Licensed under the Apache License, Version 2.0 (the "License");
7 !* you may not use this file except in compliance with the License.
8 !* You may obtain a copy of the License at
9 !*
10 !* http://www.apache.org/licenses/LICENSE-2.0
11 !*
12 !* FMS is distributed in the hope that it will be useful, but WITHOUT
13 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
14 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
15 !* PARTICULAR PURPOSE. See the License for the specific language
16 !* governing permissions and limitations under the License.
17 !***********************************************************************
18 !> @defgroup time_manager_mod time_manager_mod
19 !> @ingroup time_manager
20 !> @brief A software package that provides a set of simple interfaces for
21 !! modelers to perform computations related to time and dates.
22 !!
23 !! Optional error flag can be used in calling arguments of public routines.
24 !! This allows the using routine to terminate the program. It is likely that more
25 !! diagnostic information is available from the user than from time_manager alone.
26 !! If the error flag is present then it is the responsibility of the using
27 !! routine to test it and add additional information to the error message.
28 !!
29 !! Calendar specific routines are private.
30 !! They are not used, and should not be used, by any using code.
31 !!
32 !! The module defines a type that can be used to represent discrete
33 !! times (accurate to one second) and to map these times into dates
34 !! using a variety of calendars. A time is mapped to a date by
35 !! representing the time with respect to an arbitrary base date (refer
36 !! to <B>NOTES</B> section for the base date setting).
37 !!
38 !! The time_manager provides a single defined type, time_type, which is
39 !! used to store time and date quantities. A time_type is a positive
40 !! definite quantity that represents an interval of time. It can be
41 !! most easily thought of as representing the number of seconds in some
42 !! time interval. A time interval can be mapped to a date under a given
43 !! calendar definition by using it to represent the time that has passed
44 !! since some base date. A number of interfaces are provided to operate
45 !! on time_type variables and their associated calendars. Time intervals
46 !! can be as large as n days where n is the largest number represented by
47 !! the default integer type on a compiler. This is typically considerably
48 !! greater than 10 million years (assuming 32 bit integer representation)
49 !! which is likely to be adequate for most applications. The description
50 !! of the interfaces is separated into two sections. The first deals with
51 !! operations on time intervals while the second deals with operations
52 !! that convert time intervals to dates for a given calendar.
53 !!
54 !! The smallest increment of time is referred to as a tick.
55 !! A tick cannot be larger than 1 second, which also is the default.
56 !! The number of ticks per second is set via pubic subroutine set_ticks_per_second.
57 !! For example, ticks_per_second = 1000 will set the tick to one millisecond.
58 
59 !> @addtogroup time_manager_mod
60 !> @{
61 module time_manager_mod
62 
63 
64 use platform_mod, only: r8_kind, r4_kind
65 use constants_mod, only: rseconds_per_day=>seconds_per_day
66 use fms_mod, only: error_mesg, fatal, warning, write_version_number, stdout
67 
68 implicit none
69 private
70 
71 ! Module defines a single type
72 public time_type
73 
74 ! Operators defined on time_type
75 public operator(+), operator(-), operator(*), operator(/), &
76  operator(>), operator(>=), operator(==), operator(/=), &
77  operator(<), operator(<=), operator(//), assignment(=)
78 
79 ! Subroutines and functions operating on time_type
82 public time_list_error
83 
84 ! List of available calendar types
85 public thirty_day_months, julian, gregorian, noleap, no_calendar, invalid_calendar
86 
87 ! Subroutines and functions involving relations between time and calendar
88 public set_calendar_type
89 public get_calendar_type
92 public set_date
93 public get_date
94 public increment_date
95 public decrement_date
96 public days_in_month
97 public leap_year
98 public length_of_year
99 public days_in_year
100 public day_of_year
101 public month_name
102 
104 
105 ! Subroutines for printing version number and time type
107 
108 ! The following exist only for interpolator.F90
109 ! interpolator.F90 uses them to do a calendar conversion,
110 ! which is also done by get_cal_time. interpolator.F90
111 ! should be modified to use get_cal_time instead.
112 ! After interpolator.F90 is fixed, these can be removed
113 ! and the corresponding private routines can be renamed.
114 ! (e.g., rename set_date_julian_private to be just set_date_julian)
115 public :: set_date_julian, set_date_no_leap, get_date_julian, get_date_no_leap
116 
117 public :: date_to_string
118 
119 !====================================================================
120 
121 ! Global data to define calendar type
122 integer, parameter :: THIRTY_DAY_MONTHS = 1, julian = 2, &
123  gregorian = 3, noleap = 4, &
124  no_calendar = 0, invalid_calendar =-1
125 integer, private :: calendar_type = no_calendar
126 integer, parameter :: max_type = 4
127 
128 ! Define number of days per month
129 integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
130 integer, parameter :: seconds_per_day = rseconds_per_day ! This should automatically cast real to integer
131 integer, parameter :: days_in_400_year_period = 146097 !< Used only for gregorian
132 integer,parameter :: do_floor = 0
133 integer,parameter :: do_nearest = 1
134 
135 !> @}
136 
137 !> @brief Type to represent amounts of time.
138 !> Implemented as seconds and days to allow for larger intervals.
139 !> @ingroup time_manager_mod
140 type :: time_type
141  private
142  integer:: seconds
143  integer:: days
144  integer:: ticks
145 end type time_type
146 
147 !> Operator override interface for use with @ref time_type
148 !> @ingroup time_manager_mod
149 interface operator (+); module procedure time_plus; end interface
150 !> Operator override interface for use with @ref time_type
151 !> @ingroup time_manager_mod
152 interface operator (-); module procedure time_minus; end interface
153 !> Operator override interface for use with @ref time_type
154 !> @ingroup time_manager_mod
155 interface operator (*); module procedure time_scalar_mult
156  module procedure scalar_time_mult; end interface
157 !> Operator override interface for use with @ref time_type
158 !> @ingroup time_manager_mod
159 interface operator (/); module procedure time_scalar_divide
160  module procedure time_divide; end interface
161 !> Operator override interface for use with @ref time_type
162 !> @ingroup time_manager_mod
163 interface operator (>); module procedure time_gt; end interface
164 !> Operator override interface for use with @ref time_type
165 !> @ingroup time_manager_mod
166 interface operator (>=); module procedure time_ge; end interface
167 !> Operator override interface for use with @ref time_type
168 !> @ingroup time_manager_mod
169 interface operator (<); module procedure time_lt; end interface
170 !> Operator override interface for use with @ref time_type
171 !> @ingroup time_manager_mod
172 interface operator (<=); module procedure time_le; end interface
173 !> Operator override interface for use with @ref time_type
174 !> @ingroup time_manager_mod
175 interface operator (==); module procedure time_eq; end interface
176 !> Operator override interface for use with @ref time_type
177 !> @ingroup time_manager_mod
178 interface operator (/=); module procedure time_ne; end interface
179 !> Operator override interface for use with @ref time_type
180 !> @ingroup time_manager_mod
181 interface operator (//); module procedure time_real_divide; end interface
182 !> Operator override interface for use with @ref time_type
183 !> @ingroup time_manager_mod
184 interface assignment(=); module procedure time_assignment; end interface
185 
186 !======================================================================
187 
188 !> @brief Given some number of seconds and days, returns the
189 !! corresponding time_type.
190 !!
191 !> Given some number of seconds and days, returns the
192 !! corresponding time_type. set_time has two forms;
193 !! one accepts integer input, the other a character string with the day and second counts.
194 !! For the first form, there are no restrictions on the range of the inputs,
195 !! except that the result must be positive time.
196 !! e.g. days=-1, seconds=86401 is acceptable.
197 !! For the second form, days and seconds must both be positive.
198 !!
199 !! <br>Example usage:
200 !! @code{.F90}
201 !! type(time_type) :: time1, time2
202 !! time1 = set_time(seconds, days, ticks, err_msg)
203 !! time2 = set_time("100 43200", err_msg, allow_rounding)
204 !! @endcode
205 !> @ingroup time_manager_mod
206 interface set_time
207  module procedure set_time_i, set_time_c
208 end interface
209 
210 !> @brief Given an input date in year, month, days, etc., creates a
211 !! time_type that represents this time interval from the
212 !! internally defined base date.
213 !!
214 !> Given a date, computes the corresponding time given the selected
215 !! date time mapping algorithm. Note that it is possible to specify
216 !! any number of illegal dates; these should be checked for and generate
217 !! errors as appropriate.
218 !!
219 !! <br>Example usage:
220 !! <br> Integer input
221 !! @code{.F90} time = set_date(year, month, day, hours, minute, second, tick, err_msg) @endcode
222 !! <br> String input
223 !! @code{.F90} time = set_date(time_string, zero_year_warning, err_msg, allow_rounding) @endcode
224 !!
225 !! @param time_string A character string containing a date formatted
226 !! according to CF conventions. e.g. '1980-12-31 23:59:59.9'
227 !!
228 !! @param zero_year_warning If the year number is zero, it will be silently changed to one,
229 !! unless zero_year_warning=.true., in which case a WARNING message
230 !! will also be issued.
231 !!
232 !! @param allow_rounding When .true., any fractions of a second will be rounded off to the nearest
233 !! tick. When .false., it is a fatal error if the second fraction cannot be exactly
234 !! represented by a number of ticks.
235 !!
236 !! @param err_msg When present, and when non-blank, a fatal error condition as been detected.
237 !! The string itself is an error message.
238 !! It is recommended that, when err_msg is present in the call
239 !! to this routine, the next line of code should be something
240 !! similar to this:
241 !! @code{.F90}
242 !! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg) ,FATAL)
243 !! @endcode
244 !!
245 !> @ingroup time_manager_mod
246 interface set_date
247  module procedure set_date_i, set_date_c
248 end interface
249 
250 !> Wrapper for the real to time interface
251 !! Takes seconds as reals to convert to a time_type representation of an interval
252 !! r4 versions just casts to r8
254  module procedure real4_to_time_type
255  module procedure real8_to_time_type
256 end interface
257 
258 !> @addtogroup time_manager_mod
259 !> @{
260 
261 !======================================================================
262 
263 ! Include variable "version" to be written to log file.
264 #include<file_version.h>
265 logical :: module_is_initialized = .false.
266 
267 !======================================================================
268 
269 ! A tick is the smallest increment of time.
270 ! That is, smallest increment of time = (1/ticks_per_second) seconds
271 
272 integer :: ticks_per_second = 1
273 
274 !======================================================================
275 contains
276 
277 ! First define all operations on time intervals independent of calendar
278 
279 !> Returns a time interval corresponding to this number of days, seconds, and ticks.
280 !! days, seconds and ticks may be negative, but resulting time must be positive.
281  function set_time_private(seconds, days, ticks, Time_out, err_msg)
282 
283 ! -- pjp --
284 ! To understand why inputs may be negative,
285 ! one needs to understand the intrinsic function "modulo".
286 ! The expanation below is copied from a web page on fortran 90
287 
288 ! In addition, CEILING, FLOOR and MODULO have been added to Fortran 90.
289 ! Only the last one is difficult to explain, which is most easily done with the examples from ISO (1991)
290 
291 ! MOD (8,5) gives 3 MODULO (8,5) gives 3
292 ! MOD (-8,5) gives -3 MODULO (-8,5) gives 2
293 ! MOD (8,-5) gives 3 MODULO (8,-5) gives -2
294 ! MOD (-8,-5) gives -3 MODULO (-8,-5) gives -3
295 
296 ! I don't think it is difficult to explain.
297 ! I think that is it sufficient to say this:
298 ! "The result of modulo(n,m) has the sign of m"
299 ! -- pjp --
300 
301  logical :: set_time_private
302  integer, intent(in) :: seconds, days, ticks
303  type(time_type), intent(out) :: time_out
304  character(len=*), intent(out) :: err_msg
305  integer :: seconds_new, days_new, ticks_new
306 
307  seconds_new = seconds + floor(real(ticks, r8_kind)/real(ticks_per_second, r8_kind))
308  ticks_new = modulo(ticks,ticks_per_second)
309  days_new = days + floor(real(seconds_new, r8_kind)/real(seconds_per_day, r8_kind))
310  seconds_new = modulo(seconds_new,seconds_per_day)
311 
312  if ( seconds_new < 0 .or. ticks_new < 0) then
313  call error_mesg('function set_time_i','Bad result for time. Contact those responsible for maintaining time_manager'&
314  & ,fatal)
315  endif
316 
317  if(days_new < 0) then
318  write(err_msg,'(a,i6,a,i6,a,i6)') 'time is negative. days=',days_new,' seconds=',seconds_new,' ticks=',ticks_new
319  set_time_private = .false.
320  else
321  time_out%days = days_new
322  time_out%seconds = seconds_new
323  time_out%ticks = ticks_new
324  err_msg = ''
325  set_time_private = .true.
326  endif
327 
328  end function set_time_private
329 !---------------------------------------------------------------------------
330  !> @brief Returns a time_type set to the given amount of time via integer amounts.
331  function set_time_i(seconds, days, ticks, err_msg)
332  type(time_type) :: set_time_i
333  integer, intent(in) :: seconds !< A number of seconds
334  integer, intent(in), optional :: days !< A number of days
335  integer, intent(in), optional :: ticks !< A number of ticks
336  character(len=*), intent(out), optional :: err_msg !< When present, and when non-blank, a fatal
337  !! error condition as been detected. The string itself is an error message.
338  !! It is recommended that, when err_msg is present in the call
339  !! to this routine, the next line of code should be something
340  !! similar to this:
341  !! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
342  character(len=128) :: err_msg_local
343  integer :: odays, oticks
344 
345  if(.not.module_is_initialized) call time_manager_init
346 
347  odays = 0; if(present(days)) odays = days
348  oticks = 0; if(present(ticks)) oticks = ticks
349  if(present(err_msg)) err_msg = ''
350 
351  if(.not.set_time_private(seconds, odays, oticks, set_time_i, err_msg_local)) then
352  if(error_handler('function set_time_i', trim(err_msg_local), err_msg)) return
353  endif
354 
355  end function set_time_i
356 !---------------------------------------------------------------------------
357 
358  !> @brief Returns a time_type set to the given amount of time via a string
359  function set_time_c(string, err_msg, allow_rounding)
360 
361  type(time_type) :: set_time_c
362  character(len=*), intent(in) :: string !< Contains days and seconds separated by a single blank.
363  !! days must be integer, seconds may be integer or real.
364  !! Examples: '100 43200' '100 43200.50'
365  character(len=*), intent(out), optional :: err_msg !< When present, and when non-blank, a fatal
366  !! error condition as been detected. The string itself is an error message.
367  !! It is recommended that, when err_msg is present in the call
368  !! to this routine, the next line of code should be something
369  !! similar to this:
370  !! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
371  logical, intent(in), optional :: allow_rounding !< When .true., any fractions of a second will be
372  !! rounded off to the nearest tick. When .false., it is a fatal error
373  !! if the second fraction cannot be exactly represented by a number of ticks.
374 
375  character(len=4) :: formt='(i )'
376  integer :: i1, i2, i3, day, second, tick, nsps
377  character(len=32) :: string_sifted_left
378  character(len=128) :: err_msg_local
379  logical :: allow_rounding_local
380 
381  if(.not.module_is_initialized) call time_manager_init
382  if(present(err_msg)) err_msg = ''
383  allow_rounding_local=.true.; if(present(allow_rounding)) allow_rounding_local=allow_rounding
384 
385  err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)
386 
387  string_sifted_left = adjustl(string)
388  i1 = index(trim(string_sifted_left),' ')
389  if(i1 == 0) then
390  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
391  endif
392  if(index(string,'-') /= 0 .or. index(string,':') /= 0) then
393  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
394  endif
395 
396  i2 = index(trim(string_sifted_left),'.')
397  i3 = len_trim(cut0(string_sifted_left))
398 
399  if(i2 /= 0) then ! There is no decimal point
400  ! Check that decimal is on seconds (not days)
401  if(i2 < i1) then
402  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
403  endif
404  endif
405  write(formt(3:3),'(i1)') i1-1
406  read(string_sifted_left(1:i1-1),formt) day
407 
408  if(i2 == 0) then ! There is no decimal point
409  write(formt(3:3),'(i1)') i3-i1
410  read(string_sifted_left(i1+1:i3),formt) second
411  tick = 0
412  else ! There is a decimal point
413  ! nsps = spaces occupied by whole number of seconds
414  nsps = i2-i1-1
415  if(nsps == 0) then
416  second = 0
417  else
418  write(formt(3:3),'(i1)') nsps
419  read(string_sifted_left(i1+1:i2-1),formt) second
420  endif
421 
422  if(.not.get_tick_from_string(string_sifted_left(i2:i3), err_msg_local, allow_rounding_local, tick)) then
423  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
424  endif
425  ! If tick has been rounded up to ticks_per_second, then bump up second.
426  if(tick == ticks_per_second) then
427  second = second + 1
428  tick = 0
429  endif
430  endif
431 
432  if(.not.set_time_private(second, day, tick, set_time_c, err_msg_local)) then
433  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
434  endif
435 
436  end function set_time_c
437 !---------------------------------------------------------------------------
438 
439  function get_tick_from_string(string, err_msg, allow_rounding, tick)
440 
441  logical :: get_tick_from_string
442  character(len=*), intent(in) :: string
443  character(len=*), intent(out) :: err_msg
444  logical, intent(in) :: allow_rounding
445  integer, intent(out) :: tick
446 
447  character(len=4) :: formt='(i )'
448  integer :: i3, nspf, fraction, magnitude, tpsfrac
449 
450  err_msg = ''
451  get_tick_from_string = .true.
452  i3 = len_trim(string)
453  nspf = i3 - 1 ! nspf = spaces occupied by fractional seconds, excluding decimal point
454  if(nspf == 0) then
455  tick = 0 ! Nothing to the right of the decimal point
456  else
457  write(formt(3:3),'(i1)') nspf
458  read(string(2:i3),formt) fraction
459  if(fraction == 0) then
460  tick = 0 ! All zeros to the right of the decimal point
461  else
462  magnitude = 10**nspf
463  tpsfrac = ticks_per_second*fraction
464  if(allow_rounding) then
465  tick = nint((real(tpsfrac, r8_kind)/real(magnitude, r8_kind)))
466  else
467  if(modulo(tpsfrac,magnitude) == 0) then
468  tick = tpsfrac/magnitude
469  else
470  write(err_msg,'(a,i6)') 'Second fraction cannot be exactly represented with ticks. '// &
471  'fraction='//trim(string)//' ticks_per_second=',ticks_per_second
472  get_tick_from_string = .false.
473  endif
474  endif
475  endif
476  endif
477 
478  end function get_tick_from_string
479 
480 !> @brief Returns days and seconds ( < 86400 ) corresponding to a time.
481 !! <TT>err_msg</TT> should be checked for any errors.
482 !!
483 !> @param time A @ref time_type interval to get days and seconds from
484 !! @param [out] seconds The number of seconds
485 !! @param [out] days The number of seconds
486 !! @param [out] ticks The number of ticks
487 !! @param [out] err_msg Contains an error message on failure
488 !! <br>Example usage:
489 !! @code{.F90} get_time(time, seconds, days, ticks, err_msg) @endcode
490 subroutine get_time(Time, seconds, days, ticks, err_msg)
491 
492 ! Returns days and seconds ( < 86400 ) corresponding to a time.
493 
494 type(time_type), intent(in) :: time
495 integer, intent(out) :: seconds
496 integer, intent(out), optional :: days, ticks
497 character(len=*), intent(out), optional :: err_msg
498 character(len=128) :: err_msg_local
499 
500 if(.not.module_is_initialized) call time_manager_init
501 if(present(err_msg)) err_msg = ''
502 
503 seconds = time%seconds
504 
505 if(present(ticks)) then
506  ticks = time%ticks
507 else
508  if(time%ticks /= 0) then
509  err_msg_local = 'subroutine get_time: ticks must be present when time has a second fraction'
510  if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
511  endif
512 endif
513 
514 if (present(days)) then
515  days = time%days
516 else
517  if (time%days > (huge(seconds) - seconds)/seconds_per_day) then
518  err_msg_local = 'Integer overflow in seconds. Optional argument days must be present.'
519  if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
520  endif
521  seconds = seconds + time%days * seconds_per_day
522 endif
523 
524 end subroutine get_time
525 
526  !> @brief Increments a time by seconds and days.
527  !!
528  !> Given a time and an increment of days and seconds, returns
529  !! a new time_type that represents the given time after the given increment.
530  !! @returns incremented @ref time_type
531  function increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
532 
533  type(time_type) :: increment_time
534  type(time_type), intent(in) :: time !< A time interval
535  integer, intent(in) :: seconds !< Increment of seconds
536  integer, intent(in), optional :: days, ticks !< Increment of days and ticks
537  character(len=*), intent(out), optional :: err_msg !< When present and non-blank, a fatal error
538  !! condition has been detected, with the string itself
539  !! as the error message.
540  logical, intent(in), optional :: allow_neg_inc !< When false, negative increments give fatal errors
541  !! Defaults to true.
542  integer :: odays, oticks
543  character(len=128) :: err_msg_local
544  logical :: allow_neg_inc_local
545 
546  odays = 0; if(present(days)) odays = days
547  oticks = 0; if(present(ticks)) oticks = ticks
548  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
549 
550  if(.not.allow_neg_inc_local) then
551  if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
552  write(err_msg_local,10) seconds, odays, oticks
553  10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6)
554  if(error_handler('function increment_time', err_msg_local, err_msg)) return
555  endif
556  endif
557 
558  if(.not.increment_time_private(time, seconds, odays, oticks, increment_time, err_msg_local)) then
559  if(error_handler('function increment_time', err_msg_local, err_msg)) return
560  endif
561 
562  end function increment_time
563 !--------------------------------------------------------------------------
564 
565  !> Increments a time by seconds, days and ticks.
566  function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)
567 
568 
569  logical :: increment_time_private
570  type(time_type), intent(in) :: time_in
571  integer, intent(in) :: seconds, days, ticks
572  type(time_type), intent(out) :: time_out
573  character(len=*), intent(out) :: err_msg
574 
575 ! Watch for immediate overflow on days or seconds
576  if(days >= huge(days) - time_in%days) then
577  err_msg = 'Integer overflow in days in increment_time'
578  increment_time_private = .false.
579  return
580  endif
581  if(seconds >= huge(seconds) - time_in%seconds) then
582  err_msg = 'Integer overflow in seconds in increment_time'
583  increment_time_private = .false.
584  return
585  endif
586 
587  increment_time_private = set_time_private(time_in%seconds+seconds, time_in%days+days, time_in%ticks+ticks, &
588  & time_out, err_msg)
589 
590  end function increment_time_private
591 
592 !--------------------------------------------------------------------------
593 
594 !> @brief Decrements a time by seconds and days.
595 !!
596 !> Given a time and a decrement of days and seconds, returns
597 !! a time that subtracts this decrement from an input time.
598 !> @returns A time that suvtracts this decrement from an input time. A negative result is a fatal error.
599 function decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
600 
601 ! Decrements a time by seconds, days and ticks.
602 
603 type(time_type) :: decrement_time
604 type(time_type), intent(in) :: time !< A time interval
605 integer, intent(in) :: seconds !< Decrement of seconds
606 integer, intent(in), optional :: days, ticks !< Decrement of days and ticks
607 character(len=*), intent(out), optional :: err_msg !< Present and non-blank when a fatal error has
608  !! occurred, holds the error message.
609 logical, intent(in), optional :: allow_neg_inc !< Throws fatal warning when set to false if
610  !! negative values are used to decrement. Default
611  !! is true.
612 
613 integer :: odays, oticks
614 character(len=128) :: err_msg_local
615 logical :: allow_neg_inc_local
616 
617 odays = 0; if (present(days)) odays = days
618 oticks = 0; if (present(ticks)) oticks = ticks
619 allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
620 
621 if(.not.allow_neg_inc_local) then
622  if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
623  write(err_msg_local,10) seconds,odays,oticks
624  10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6)
625  if(error_handler('function decrement_time', err_msg_local, err_msg)) return
626  endif
627 endif
628 
629  if(.not.increment_time_private(time, -seconds, -odays, -oticks, decrement_time, err_msg_local)) then
630  if(error_handler('function decrement_time', err_msg_local, err_msg)) return
631  endif
632 
633 end function decrement_time
634 
635 !--------------------------------------------------------------------------
636 
637 !> @brief Returns true if time1 > time2
638 function time_gt(time1, time2)
639 
640 logical :: time_gt
641 type(time_type), intent(in) :: time1 !< time interval to compare
642 type(time_type), intent(in) :: time2 !< time interval to compare
643 
644 time_gt = (time1%days > time2%days)
645 if(time1%days == time2%days) then
646  if(time1%seconds == time2%seconds) then
647  time_gt = (time1%ticks > time2%ticks)
648  else
649  time_gt = (time1%seconds > time2%seconds)
650  endif
651 endif
652 
653 end function time_gt
654 
655 !--------------------------------------------------------------------------
656 
657 !> Returns true if time1 >= time2.
658 function time_ge(time1, time2)
659 logical :: time_ge
660 type(time_type), intent(in) :: time1 !< time interval to compare
661 type(time_type), intent(in) :: time2 !< time interval to compare
662 
663 time_ge = (time_gt(time1, time2) .or. time_eq(time1, time2))
664 
665 end function time_ge
666 
667 !--------------------------------------------------------------------------
668 
669 !> Returns true if time1 < time2
670 function time_lt(time1, time2)
671 logical :: time_lt
672 type(time_type), intent(in) :: time1 !< time interval to compare
673 type(time_type), intent(in) :: time2 !< time interval to compare
674 
675 time_lt = (time1%days < time2%days)
676 if(time1%days == time2%days)then
677  if(time1%seconds == time2%seconds) then
678  time_lt = (time1%ticks < time2%ticks)
679  else
680  time_lt = (time1%seconds < time2%seconds)
681  endif
682 endif
683 end function time_lt
684 
685 !--------------------------------------------------------------------------
686 
687 !> Returns true if time1 <= time2
688 function time_le(time1, time2)
689 logical :: time_le
690 type(time_type), intent(in) :: time1 !< time interval to compare
691 type(time_type), intent(in) :: time2 !< time interval to compare
692 
693 time_le = (time_lt(time1, time2) .or. time_eq(time1, time2))
694 
695 end function time_le
696 
697 !--------------------------------------------------------------------------
698 
699 !> Returns true if time1 == time2
700 function time_eq(time1, time2)
701 logical :: time_eq
702 type(time_type), intent(in) :: time1 !< time interval to compare
703 type(time_type), intent(in) :: time2 !< time interval to compare
704 
705 if(.not.module_is_initialized) call time_manager_init
706 
707 time_eq = (time1%seconds == time2%seconds .and. time1%days == time2%days &
708  .and. time1%ticks == time2%ticks)
709 
710 end function time_eq
711 
712 !--------------------------------------------------------------------------
713 
714 !> Returns true if time1 /= time2
715 function time_ne(time1, time2)
716 logical :: time_ne
717 type(time_type), intent(in) :: time1 !< time interval to compare
718 type(time_type), intent(in) :: time2 !< time interval to compare
719 
720 time_ne = (.not. time_eq(time1, time2))
721 
722 end function time_ne
723 
724 !-------------------------------------------------------------------------
725 
726 !> Returns sum of two time_types
727 function time_plus(time1, time2)
728 type(time_type) :: time_plus
729 type(time_type), intent(in) :: time1 !< time interval to add
730 type(time_type), intent(in) :: time2 !< time interval to add
731 
732 if(.not.module_is_initialized) call time_manager_init
733 
734 time_plus = increment_time(time1, time2%seconds, time2%days, time2%ticks)
735 
736 end function time_plus
737 
738 !-------------------------------------------------------------------------
739 
740 !> Returns difference of two time_types. WARNING: a time type is positive
741 !! so by definition time1 - time2 is the same as time2 - time1.
742 function time_minus(time1, time2)
743 type(time_type) :: time_minus
744 type(time_type), intent(in) :: time1 !< time interval to subtract
745 type(time_type), intent(in) :: time2 !< time interval to subtract
746 
747 if(.not.module_is_initialized) call time_manager_init
748 
749 if(time1 > time2) then
750  time_minus = decrement_time(time1, time2%seconds, time2%days, time2%ticks)
751 else
752  time_minus = decrement_time(time2, time1%seconds, time1%days, time1%ticks)
753 endif
754 
755 end function time_minus
756 
757 !--------------------------------------------------------------------------
758 
759 !> Returns time multiplied by integer factor n
760 function time_scalar_mult(time, n)
762 type(time_type), intent(in) :: time !< time interval to multply
763 integer, intent(in) :: n !< factor to multiply by
764 integer :: days, seconds, ticks, num_sec
765 real(r8_kind) :: sec_prod, tick_prod
766 
767 if(.not.module_is_initialized) call time_manager_init
768 
769 !! Multiplying here in a reasonable fashion to avoid overflow is tricky
770 !! Could multiply by some large factor n, and seconds could be up to 86399
771 !! Need to avoid overflowing integers and wrapping around to negatives
772 !! ticks could be up to ticks_per_second-1
773 
774 tick_prod = real(time%ticks, r8_kind) * real(n, r8_kind)
775 num_sec = int(tick_prod/real(ticks_per_second, r8_kind))
776 sec_prod = real(time%seconds, r8_kind) * real(n, r8_kind) + real(num_sec, r8_kind)
777 ticks = int(tick_prod) - (num_sec * ticks_per_second)
778 
779 !! If sec_prod is large compared to precision of double precision, things
780 !! can go bad. Need to warn and abort on this.
781 !! The same is true of tick_prod but is is more likely to happen to sec_prod,
782 !! so let's just test sec_prod. (A test of tick_prod would be necessary only
783 !! if ticks_per_second were greater than seconds_per_day)
784 if(sec_prod /= 0.0_r8_kind) then
785  if(log10(sec_prod) > precision(sec_prod) - 3) call error_mesg('time_scalar_mult', &
786  'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',fatal)
787 end if
788 
789 days = int(sec_prod / real(seconds_per_day, r8_kind))
790 seconds = int(sec_prod - real(days, r8_kind) * real(seconds_per_day, r8_kind))
791 
792 time_scalar_mult = set_time(seconds, time%days * n + days, ticks)
793 
794 end function time_scalar_mult
795 
796 !-------------------------------------------------------------------------
797 
798 !> Returns time multipled by integer factor n
799 function scalar_time_mult(n, time)
800 
802 type(time_type), intent(in) :: time !< a time interval
803 integer, intent(in) :: n !< factor to mulitply by
804 
806 
807 end function scalar_time_mult
808 
809 !-------------------------------------------------------------------------
810 
811 !> Returns the largest integer, n, for which time1 >= time2 * n.
812 function time_divide(time1, time2)
813 
814 integer :: time_divide
815 type(time_type), intent(in) :: time1 !< a time interval (dividend)
816 type(time_type), intent(in) :: time2 !< a time interval (divisor)
817 real(r8_kind) :: d1, d2
818 
819 if(.not.module_is_initialized) call time_manager_init
820 
821 ! Convert time intervals to floating point days; risky for general performance?
822 d1 = real(time1%days, r8_kind) * real(seconds_per_day, r8_kind) + real(time1%seconds, r8_kind) &
823  + real(time1%ticks, r8_kind)/real(ticks_per_second, r8_kind)
824 d2 = real(time2%days, r8_kind) * real(seconds_per_day, r8_kind) + real(time2%seconds, r8_kind) &
825  + real(time2%ticks,r8_kind)/real(ticks_per_second, r8_kind)
826 
827 ! Get integer quotient of this, check carefully to avoid round-off problems.
828 time_divide = int(d1 / d2)
829 
830 ! Verify time_divide*time2 is <= time1 and (time_divide + 1)*time2 is > time1
831 if(time_divide * time2 > time1 .or. (time_divide + 1) * time2 <= time1) &
832  call error_mesg('time_divide',' quotient error :: notify developer',fatal)
833 
834 end function time_divide
835 
836 !> Returns the double precision quotient of two times
837 function time_real_divide(time1, time2)
838 
839 real(r8_kind) :: time_real_divide
840 type(time_type), intent(in) :: time1 !< a time interval (dividend)
841 type(time_type), intent(in) :: time2 !< a time interval (divisor)
842 real(r8_kind) :: d1, d2
843 
844 if(.not.module_is_initialized) call time_manager_init
845 
846 ! Convert time intervals to floating point seconds; risky for general performance?
847 d1 = real(time1%days, r8_kind) * real(seconds_per_day, r8_kind) + real(time1%seconds, r8_kind) + &
848  real(time1%ticks, r8_kind)/real(ticks_per_second, r8_kind)
849 d2 = real(time2%days, r8_kind) * real(seconds_per_day, r8_kind) + real(time2%seconds, r8_kind) + &
850  real(time2%ticks, r8_kind)/real(ticks_per_second, r8_kind)
851 
852 time_real_divide = d1 / d2
853 
854 end function time_real_divide
855 
856 !-------------------------------------------------------------------------
857 
858 !> Assigns all components of the time_type variable on
859 !! RHS to same components of time_type variable on LHS.
860 subroutine time_assignment(time1, time2)
861 type(time_type), intent(out) :: time1
862 type(time_type), intent(in) :: time2
863  time1%seconds = time2%seconds
864  time1%days = time2%days
865  time1%ticks = time2%ticks
866 end subroutine time_assignment
867 
868 !> Converts time to seconds and returns it as a real number
869 function time_type_to_real(time)
870 
871 real(kind=r8_kind) :: time_type_to_real
872 type(time_type), intent(in) :: time
873 
874 if(.not.module_is_initialized) call time_manager_init
875 
876 time_type_to_real = real(time%days, r8_kind) * 86400.e0_r8_kind + real(time%seconds, r8_kind) + &
877  real(time%ticks, r8_kind)/real(ticks_per_second, r8_kind)
878 
879 end function time_type_to_real
880 
881 !> @brief Convert a real number of seconds into a time_type variable.
882 !! @return A filled time type variable, and an error message if an
883 !! error occurs.
884 function real8_to_time_type(x,err_msg) result(t)
885  real(r8_kind),intent(in) :: x !< Number of seconds.
886  character(len=*),intent(out),optional :: err_msg !< Error message.
887  type(time_type) :: t
888  integer :: days
889  integer :: seconds
890  integer :: ticks
891  character(len=128) :: err_msg_local
892  real(r8_kind),parameter :: spd = 86400.0_r8_kind
893  real(r8_kind) :: tps
894  real(r8_kind) :: a
895  tps = real(ticks_per_second, r8_kind)
896  a = x/spd
897  days = safe_rtoi(a,do_floor)
898  a = x - real(days, r8_kind)*spd
899  seconds = safe_rtoi(a,do_floor)
900  a = (a - real(seconds, r8_kind))*tps
901  ticks = safe_rtoi(a,do_nearest)
902  if (.not. set_time_private(seconds,days,ticks,t,err_msg_local)) then
903  if (error_handler('function real8_to_time_type',err_msg_local,err_msg)) then
904  return
905  endif
906  endif
907 end function real8_to_time_type
908 
909 function real4_to_time_type(x, err_msg) result(t)
910  real(r4_kind), intent(in) :: x !< number of seconds
911  character(len=*),intent(out),optional :: err_msg !< Error message.
912  type(time_type) :: t
913  t = real_to_time_type(real(x, r8_kind), err_msg)
914 end function
915 
916 !> @brief Convert a floating point value to an integer value.
917 !! @return The integer value, using the input rounding mode.
918 function safe_rtoi(rval,mode) result(ival)
919  real(r8_kind),intent(in) :: rval !< A floating point value.
920  integer,intent(in) :: mode !< A rouding mode (either "do_floor" or
921  !! "do_nearest")
922  integer :: ival
923  real(r8_kind) :: big
924  big = real(huge(ival), r8_kind)
925  if (rval .le. big .and. -1.0_r8_kind*rval .ge. -1.0_r8_kind*big) then
926  if (mode .eq. do_floor) then
927  ival = floor(rval)
928  elseif (mode .eq. do_nearest) then
929  ival = nint(rval)
930  else
931  call error_mesg("safe_rtoi","mode must be either do_floor" &
932  //" or do_nearest.",fatal)
933  endif
934  else
935  call error_mesg("safe_rtoi","input value cannot be safely" &
936  //" converted to a 32-bit integer.",fatal)
937  endif
938 end function safe_rtoi
939 
940 !-------------------------------------------------------------------------
941 
942 !> Returns the largest time, t, for which n * t <= time.
943 function time_scalar_divide(time, n)
945 type(time_type), intent(in) :: time !< time interval to divide
946 integer, intent(in) :: n !< divisor
947 real(r8_kind) :: d, div, dseconds_per_day, dticks_per_second
948 integer :: days, seconds, ticks
949 type(time_type) :: prod1, prod2
950 character(len=128) tmp1,tmp2
951 logical :: ltmp
952 
953 ! Convert time interval to floating point days; risky for general performance?
954 dseconds_per_day = real(seconds_per_day, r8_kind)
955 dticks_per_second = real(ticks_per_second, r8_kind)
956 d = real(time%days,r8_kind)*dseconds_per_day*dticks_per_second + real(time%seconds, r8_kind)*dticks_per_second + &
957  real(time%ticks, r8_kind)
958 div = d/real(n, r8_kind)
959 
960 days = int(div/(dseconds_per_day*dticks_per_second))
961 seconds = int(div/dticks_per_second - real(days, r8_kind)*dseconds_per_day)
962 ticks = int(div - (real(days, r8_kind)*dseconds_per_day + real(seconds, r8_kind))*dticks_per_second)
963 time_scalar_divide = set_time(seconds, days, ticks)
964 
965 ! Need to make sure that roundoff isn't killing this
966 prod1 = n * time_scalar_divide
967 prod2 = n * (increment_time(time_scalar_divide, days=0, seconds=0, ticks=1))
968 if(prod1 > time .or. prod2 <= time) then
969  call get_time(time, seconds, days, ticks)
970  write(tmp1,20) days,seconds,ticks
971  call get_time(time_scalar_divide, seconds, days, ticks)
972  write(tmp2,30) n,days,seconds,ticks
973  ltmp = error_handler('time_scalar_divide',' quotient error:'//trim(tmp1)//trim(tmp2))
974  20 format('time=',i7,' days, ',i6,' seconds, ',i6,' ticks')
975  30 format(' time divided by',i6,'=',i7,' days, ',i6,' seconds, ',i6,' ticks')
976 endif
977 
978 end function time_scalar_divide
979 
980 !> Supports a commonly used type of test on times for models. Given the
981 !! current time, and a time for an alarm, determines if this is the closest
982 !! time to the alarm time given a time step of time_interval. If this
983 !! is the closest time (alarm - time <= time_interval/2), the function
984 !! returns true and the alarm is incremented by the alarm_interval. Watch
985 !! for problems if the new alarm time is less than time + time_interval
986 !!
987 !! This is a specialized operation that is frequently performed in models.
988 !! Given a time, and a time interval, this function is true if this is the
989 !! closest time step to the alarm time. The actual computation is:
990 !!
991 !! if((alarm_time - time) &#60;&#61; (time_interval / 2))
992 !!
993 !! If the function is true, the alarm time is incremented by the
994 !! alarm_interval; WARNING, this is a featured side effect. Otherwise, the
995 !! function is false and there are no other effects. CAUTION: if the
996 !! alarm_interval is smaller than the time_interval, the alarm may fail to
997 !! return true ever again. Watch
998 !! for problems if the new alarm time is less than time + time_interval
999 function interval_alarm(time, time_interval, alarm, alarm_interval)
1000 logical :: interval_alarm
1001 type(time_type), intent(in) :: time !< current time
1002 type(time_type), intent(in) :: time_interval !< a time interval
1003 type(time_type), intent(in) :: alarm_interval !< a time interval
1004 type(time_type), intent(inout) :: alarm !< An alarm time, which is incremented by the alarm_interval if
1005  !! the function is true.
1006 
1007 if((alarm - time) <= (time_interval / 2)) then
1008  interval_alarm = .true.
1009  alarm = alarm + alarm_interval
1010 else
1011  interval_alarm = .false.
1012 end if
1013 
1014 end function interval_alarm
1015 
1016 !--------------------------------------------------------------------------
1017 
1018 !> Repeat_alarm supports an alarm that goes off with alarm_frequency and
1019 !! lasts for alarm_length. If the nearest occurence of an alarm time
1020 !! is less than half an alarm_length from the input time, repeat_alarm
1021 !! is true. For instance, if the alarm_frequency is 1 day, and the
1022 !! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on
1023 !! day n to time 0100 on day n + 1 for all n.
1024 function repeat_alarm(time, alarm_frequency, alarm_length)
1025 logical :: repeat_alarm
1026 type(time_type), intent(in) :: time !< current time
1027 type(time_type), intent(in) :: alarm_frequency !< a time interval for time in between alarm activations
1028 type(time_type), intent(in) :: alarm_length !< a time interval for amount of time alarm is active for
1029 type(time_type) :: prev, next
1030 
1031 prev = (time / alarm_frequency) * alarm_frequency
1032 next = prev + alarm_frequency
1033 if(time - prev <= alarm_length / 2 .or. next - time <= alarm_length / 2) then
1034  repeat_alarm = .true.
1035 else
1036  repeat_alarm = .false.
1037 endif
1038 
1039 end function repeat_alarm
1040 
1041 !--------------------------------------------------------------------------
1042 
1043 !=========================================================================
1044 ! CALENDAR OPERATIONS BEGIN HERE
1045 !=========================================================================
1046 
1047 ! <SUBROUTINE NAME="set_calendar_type">
1048 
1049 ! <OVERVIEW>
1050 ! Sets the default calendar type for mapping time intervals to dates.
1051 ! </OVERVIEW>
1052 ! <DESCRIPTION>
1053 ! A constant number for setting the calendar type.
1054 ! </DESCRIPTION>
1055 ! <TEMPLATE> set_calendar_type(type, err_msg) </TEMPLATE>
1056 
1057 ! <IN NAME="type" TYPE="integer" DIM="(scalar)" DEFAULT="NO_CALENDAR">
1058 ! A constant number for setting the calendar type.
1059 ! </IN>
1060 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1061 ! When present, and when non-blank, a fatal error condition as been detected.
1062 ! The string itself is an error message.
1063 ! It is recommended that, when err_msg is present in the call
1064 ! to this routine, the next line of code should be something
1065 ! similar to this:
1066 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1067 ! </OUT>
1068 
1069 !> @brief Sets calendar_type for mapping an interval to a date.
1070 !! For the Gregorian calendar, negative years and the proleptic calendar are not used;
1071 !! and the discontinuity of days in October 1582 (when the Gregorian calendar was adopted by select groups in Europe)
1072 !! is also not taken into account.
1073 subroutine set_calendar_type(type, err_msg)
1074 
1075 ! Selects calendar for default mapping from time to date.
1076 
1077 integer, intent(in) :: type !< constant parameter value (ie. one NO_CALENDAR, )
1078 character(len=*), intent(out), optional :: err_msg
1079 character(len=256) :: err_msg_local
1080 
1081 if(.not.module_is_initialized) call time_manager_init()
1082 
1083 if(present(err_msg)) err_msg = ''
1084 
1085 if(type < 0 .or. type > max_type) then
1086  err_msg_local = 'Illegal calendar type'
1087  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
1088 endif
1089 
1090 if(seconds_per_day /= 86400 .and. type /= no_calendar ) then
1091  err_msg_local = 'Only calendar type NO_CALENDAR is allowed when seconds_per_day is not 86400.'// &
1092  ' You are using '//trim(valid_calendar_types(type))//' and seconds_per_day='
1093  write(err_msg_local(len_trim(err_msg_local)+1:len_trim(err_msg_local)+8),'(i8)') seconds_per_day
1094  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
1095 endif
1096 
1097 calendar_type = type
1098 
1099 end subroutine set_calendar_type
1100 
1101 !------------------------------------------------------------------------
1102 
1103 !> Returns default calendar type for mapping from time to date.
1105 
1106 integer :: get_calendar_type
1107 
1108 get_calendar_type = calendar_type
1109 
1110 end function get_calendar_type
1111 
1112 !------------------------------------------------------------------------
1113 
1114 !> Sets the number of ticks per second.
1115 subroutine set_ticks_per_second(tps)
1116 integer, intent(in) :: tps
1117 
1118 ticks_per_second = tps
1119 
1120 end subroutine set_ticks_per_second
1121 
1122 !------------------------------------------------------------------------
1123 
1124 !> Returns the number of ticks per second.
1126 integer :: get_ticks_per_second
1127 
1128 get_ticks_per_second = ticks_per_second
1129 
1130 end function get_ticks_per_second
1131 
1132 !------------------------------------------------------------------------
1133 
1134  !> @brief Gets the date for different calendar types.
1135  !! Given a time_interval, returns the corresponding date under
1136  !! the selected calendar.
1137  !! When err_msg present, and when non-blank, a fatal error condition as been detected.
1138  !! The string itself is an error message.
1139  !! It is recommended that, when err_msg is present in the call
1140  !! to this routine, the next line of code should be something
1141  !! similar to this: <br>
1142  !!
1143  !! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1144  subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg)
1145 
1146 ! Given a time, computes the corresponding date given the selected calendar
1147 
1148  type(time_type), intent(in) :: time
1149  integer, intent(out) :: second, minute, hour, day, month, year
1150  integer, intent(out), optional :: tick
1151  character(len=*), intent(out), optional :: err_msg
1152  character(len=128) :: err_msg_local
1153  integer :: tick1
1154 
1155  if(.not.module_is_initialized) call time_manager_init
1156  if(present(err_msg)) err_msg = ''
1157 
1158  select case(calendar_type)
1159  case(thirty_day_months)
1160  call get_date_thirty(time, year, month, day, hour, minute, second, tick1)
1161  case(gregorian)
1162  call get_date_gregorian(time, year, month, day, hour, minute, second, tick1)
1163  case(julian)
1164  call get_date_julian_private(time, year, month, day, hour, minute, second, tick1)
1165  case(noleap)
1166  call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick1)
1167  case(no_calendar)
1168  err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR'
1169  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1170  case default
1171  err_msg_local = 'Invalid calendar type'
1172  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1173  end select
1174 
1175  if(present(tick)) then
1176  tick = tick1
1177  else
1178  if(tick1 /= 0) then
1179  err_msg_local = 'tick must be present when time has a second fraction'
1180  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1181  endif
1182  endif
1183 
1184  end subroutine get_date
1185 
1186 !------------------------------------------------------------------------
1187 
1188 !> @brief Gets the date on a Gregorian calendar.
1189 !! Computes the year, month, day on the fly from the quantity time%days
1190  subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)
1191 
1192  type(time_type), intent(in) :: time
1193  integer, intent(out) :: year, month, day, hour, minute, second
1194  integer, intent(out) :: tick
1195  integer :: iday, isec
1196 
1197  integer :: l !< value of 1 if leap year; value of 0 otherwise
1198  integer :: ncenturies !< number of centuries passed in the current 400 year period
1199  integer :: nlpyrs !< number of leap years in the current century
1200  integer :: yearx, monthx, dayx, idayx !< temporary values for year, month, day
1201  integer :: i !< counter, dummy variable
1202 
1203  ! Computes date corresponding to time for gregorian calendar
1204 
1205  !Carried over from the old subroutine
1206  if(time%seconds >= 86400) then ! This check appears to be unecessary.
1207  call error_mesg('get_date',.ge.'Time%seconds 86400 in subroutine get_date_gregorian',fatal)
1208  endif
1209 
1210  iday = mod(time%days+1,days_in_400_year_period)
1211 
1212  yearx = 1
1213  idayx = 0
1214  if( iday.eq.0 ) then !year 400
1215  yearx = 0
1216  idayx = -366
1217  else if( iday.gt.365 ) then
1218  yearx = int(iday/365) - 1 !approximation off by -1 year at most
1219  ncenturies = int(yearx/100)
1220  nlpyrs = int((yearx-ncenturies*100)/4)
1221  idayx = ncenturies*36524 + (yearx-ncenturies*100)*365 + nlpyrs !36524 days in a century
1222  if( ncenturies.eq.4 ) idayx = idayx + 1 !year 400 is a leap year
1223  l = 0 ; if ( leap_year_gregorian_int(yearx+1) ) l = 1
1224  if ( (iday-idayx).gt.365+l ) then !off by -1 year
1225  yearx = yearx + 1
1226  idayx = idayx + 365 + l
1227  end if
1228  yearx = yearx + 1
1229  end if
1230 
1231  year = 400*int((time%days+1)/days_in_400_year_period) + yearx
1232 
1233  l = 0 ; if( leap_year_gregorian_int(year) ) l = 1
1234  dayx = iday - idayx
1235  if( dayx.le.31 ) then
1236  month = 1
1237  day = dayx
1238  else
1239  monthx = int(dayx/30)
1240  if( l.eq.1 ) then
1241  do i=1, monthx
1242  dayx = dayx - days_per_month(i)
1243  if(i.eq.2) dayx = dayx - l
1244  end do
1245  else
1246  do i=1, monthx
1247  dayx = dayx - days_per_month(i)
1248  end do
1249  end if
1250  month = monthx + 1
1251  day = dayx
1252  if( dayx.le.0 ) then
1253  month = monthx
1254  day = dayx + days_per_month(monthx)
1255  if(monthx.eq.2) day = day + l
1256  end if
1257  end if
1258 
1259  hour = time%seconds / 3600
1260  isec = time%seconds - 3600*hour
1261  minute = isec / 60
1262  second = isec - 60*minute
1263  tick = time%ticks
1264 
1265  end subroutine get_date_gregorian
1266 !------------------------------------------------------------------------
1267 
1268  function cut0(string)
1269  character(len=256) :: cut0
1270  character(len=*), intent(in) :: string
1271  integer :: i
1272 
1273  cut0 = string
1274 
1275  do i=1,len(string)
1276  if(ichar(string(i:i)) == 0 ) then
1277  cut0(i:i) = ' '
1278  endif
1279  enddo
1280 
1281  return
1282  end function cut0
1283 !------------------------------------------------------------------------
1284 
1285 !> Base date for Julian calendar is year 1 with all multiples of 4
1286 !! years being leap years.
1287  subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)
1288 
1289 
1290  type(time_type), intent(in) :: time
1291  integer, intent(out) :: second, minute, hour, day, month, year
1292  integer, intent(out) :: tick
1293  integer :: m, t, nfour, nex, days_this_month
1294  logical :: leap
1295 
1296 ! find number of four year periods; also get modulo number of days
1297  nfour = time%days / (4 * 365 + 1)
1298  day = modulo(time%days, (4 * 365 + 1))
1299 
1300 ! Find out what year in four year chunk
1301  nex = day / 365
1302  if(nex == 4) then
1303  nex = 3
1304  day = 366
1305  else
1306  day=modulo(day, 365) + 1
1307  endif
1308 
1309 ! Is this a leap year?
1310  leap = (nex == 3)
1311 
1312  year = 1 + 4 * nfour + nex
1313 
1314 ! find month and day
1315  do m = 1, 12
1316  month = m
1317  days_this_month = days_per_month(m)
1318  if(leap .and. m == 2) days_this_month = 29
1319  if(day <= days_this_month) exit
1320  day = day - days_this_month
1321  end do
1322 
1323 ! find hour,minute and second
1324  t = time%seconds
1325  hour = t / (60 * 60)
1326  t = t - hour * (60 * 60)
1327  minute = t / 60
1328  second = t - 60 * minute
1329  tick = time%ticks
1330  end subroutine get_date_julian_private
1331 
1332 !------------------------------------------------------------------------
1333  subroutine get_date_julian(time, year, month, day, hour, minute, second)
1334 
1335 ! No need to include tick in argument list because this routine
1336 ! exists only for interpolator.F90, which does not need it.
1337 
1338  type(time_type), intent(in) :: time
1339  integer, intent(out) :: second, minute, hour, day, month, year
1340  integer :: tick
1341 
1342  call get_date_julian_private(time, year, month, day, hour, minute, second, tick)
1343 
1344  end subroutine get_date_julian
1345 
1346 !------------------------------------------------------------------------
1347 
1348  !> Computes date corresponding to time interval for 30 day months, 12
1349  !! month years.
1350  subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
1351 
1352 
1353  type(time_type), intent(in) :: time
1354  integer, intent(out) :: second, minute, hour, day, month, year
1355  integer, intent(out) :: tick
1356  integer :: t, dmonth, dyear
1357 
1358  t = time%days
1359  dyear = t / (30 * 12)
1360  year = dyear + 1
1361  t = t - dyear * (30 * 12)
1362  dmonth = t / 30
1363  month = 1 + dmonth
1364  day = t -dmonth * 30 + 1
1365 
1366  t = time%seconds
1367  hour = t / (60 * 60)
1368  t = t - hour * (60 * 60)
1369  minute = t / 60
1370  second = t - 60 * minute
1371  tick = time%ticks
1372 
1373  end subroutine get_date_thirty
1374 !------------------------------------------------------------------------
1375 
1376  subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
1377 
1378 ! Base date for NOLEAP calendar is year 1.
1379 
1380  type(time_type), intent(in) :: time
1381  integer, intent(out) :: second, minute, hour, day, month, year
1382  integer, intent(out) :: tick
1383  integer :: m, t
1384 
1385 ! get modulo number of days
1386  year = time%days / 365 + 1
1387  day = modulo(time%days, 365) + 1
1388 
1389 ! find month and day
1390  do m = 1, 12
1391  month = m
1392  if(day <= days_per_month(m)) exit
1393  day = day - days_per_month(m)
1394  end do
1395 
1396 ! find hour,minute and second
1397  t = time%seconds
1398  hour = t / (60 * 60)
1399  t = t - hour * (60 * 60)
1400  minute = t / 60
1401  second = t - 60 * minute
1402  tick = time%ticks
1403 
1404  end subroutine get_date_no_leap_private
1405 
1406 !------------------------------------------------------------------------
1407  subroutine get_date_no_leap(time, year, month, day, hour, minute, second)
1408 
1409 ! No need to include tick in argument list because this routine
1410 ! exists only for interpolator.F90, which does not need it.
1411 
1412  type(time_type), intent(in) :: time
1413  integer, intent(out) :: second, minute, hour, day, month, year
1414  integer :: tick
1415 
1416  call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
1417 
1418  end subroutine get_date_no_leap
1419 !------------------------------------------------------------------------
1420 
1421  !> @brief Sets days for different calendar types.
1422  !! Given an input date in year, month, days, etc., creates a
1423  !! time_type that represents this time interval from the
1424  !! internally defined base date.
1425  !!
1426  !! @note that it is possible to specify
1427  !! any number of illegal dates; these are checked for and generate
1428  !! errors as appropriate.
1429  function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1430 
1431 ! Given a date, computes the corresponding time given the selected
1432 ! date time mapping algorithm.
1433  logical :: set_date_private
1434  integer, intent(in) :: year, month, day, hour, minute, second, tick
1435  type(time_type) :: time_out
1436  character(len=*), intent(out) :: err_msg !< error message, if non-empty an error has occurred
1437 
1438  if(.not.module_is_initialized) call time_manager_init
1439 
1440  err_msg = ''
1441 
1442  select case(calendar_type)
1443  case(thirty_day_months)
1444  set_date_private = set_date_thirty(year, month, day, hour, minute, second, tick, time_out, err_msg)
1445  case(gregorian)
1446  set_date_private = set_date_gregorian(year, month, day, hour, minute, second, tick, time_out, err_msg)
1447  case(julian)
1448  set_date_private = set_date_julian_private(year, month, day, hour, minute, second, tick, time_out, err_msg)
1449  case(noleap)
1450  set_date_private = set_date_no_leap_private(year, month, day, hour, minute, second, tick, time_out, err_msg)
1451  case (no_calendar)
1452  err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR'
1453  set_date_private = .false.
1454  case default
1455  err_msg = 'Invalid calendar type'
1456  set_date_private = .false.
1457  end select
1458 
1459  end function set_date_private
1460 
1461 !------------------------------------------------------------------------
1462 
1463  !> @brief Calls set_date_private to set days for different calendar types.
1464  function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
1465  type(time_type) :: set_date_i
1466  integer, intent(in) :: day, month, year
1467  integer, intent(in), optional :: second, minute, hour, tick
1468  character(len=*), intent(out), optional :: err_msg
1469  integer :: osecond, ominute, ohour, otick
1470  character(len=128) :: err_msg_local
1471 
1472  if(.not.module_is_initialized) call time_manager_init
1473  if(present(err_msg)) err_msg = ''
1474 
1475 ! Missing optionals are set to 0
1476  osecond = 0; if(present(second)) osecond = second
1477  ominute = 0; if(present(minute)) ominute = minute
1478  ohour = 0; if(present(hour)) ohour = hour
1479  otick = 0; if(present(tick)) otick = tick
1480 
1481  if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local)) then
1482  if(error_handler('function set_date_i', err_msg_local, err_msg)) return
1483  end if
1484 
1485  end function set_date_i
1486 !------------------------------------------------------------------------
1487 
1488  !> @brief Calls set_date_private for different calendar types when given a string input.
1489  !! Examples of acceptable forms of string:
1490  !!
1491  !! 1980-01-01 00:00:00
1492  !! 1980-01-01 00:00:00.50
1493  !! 1980-1-1 0:0:0
1494  !! 1980-1-1
1495  !!
1496  !! year number must occupy 4 spaces.
1497  !! months, days, hours, minutes, seconds may occupy 1 or 2 spaces
1498  !! year, month and day must be separated by a '-'
1499  !! hour, minute, second must be separated by a ':'
1500  !! hour, minute, second are optional. If not present then zero is assumed.
1501  !! second may be a real number.
1502  !!
1503  !! zero_year_warning:
1504  !! If the year number is zero, it will be silently changed to one,
1505  !! unless zero_year_warning=.true., in which case a WARNING message
1506  !! will also be issued
1507  function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
1508  type(time_type) :: set_date_c
1509  character(len=*), intent(in) :: string
1510  logical, intent(in), optional :: zero_year_warning
1511  character(len=*), intent(out), optional :: err_msg
1512  logical, intent(in), optional :: allow_rounding
1513  character(len=4) :: formt='(i )'
1514  logical :: correct_form, zero_year_warning_local, allow_rounding_local
1515  integer :: i1, i2, i3, i4, i5, i6, i7
1516  character(len=32) :: string_sifted_left
1517  integer :: year, month, day, hour, minute, second, tick
1518  character(len=128) :: err_msg_local
1519 
1520  if(.not.module_is_initialized) call time_manager_init()
1521  if(present(err_msg)) err_msg = ''
1522  if(present(zero_year_warning)) then
1523  zero_year_warning_local = zero_year_warning
1524  else
1525  zero_year_warning_local = .true.
1526  endif
1527  if(present(allow_rounding)) then
1528  allow_rounding_local = allow_rounding
1529  else
1530  allow_rounding_local = .true.
1531  endif
1532 
1533  string_sifted_left = adjustl(string)
1534  i1 = index(string_sifted_left,'-')
1535  i2 = index(string_sifted_left,'-',back=.true.)
1536  i3 = index(string_sifted_left,':')
1537  i4 = index(string_sifted_left,':',back=.true.)
1538  i5 = len_trim(cut0(string_sifted_left))
1539  i6 = index(string_sifted_left,'.',back=.true.)
1540  correct_form = (i1 > 1) ! year number must occupy at least 1 space
1541  correct_form = correct_form .and. (i2-i1 == 2 .or. i2-i1 == 3) ! month number must occupy 1 or 2 spaces
1542  if(.not.correct_form) then
1543  err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)
1544  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
1545  endif
1546  write(formt(3:3),'(i1)') i1-1
1547  read(string_sifted_left(1:i1-1),formt) year
1548  if(year == 0) then
1549  year = 1
1550  if(zero_year_warning_local) then
1551  call error_mesg('set_date_c','Year zero is invalid. Resetting year to 1', warning)
1552  endif
1553  endif
1554  write(formt(3:3),'(i1)') i2-i1-1
1555  read(string_sifted_left(i1+1:i2-1),formt) month
1556  i7 = min(i2+2,i5)
1557  read(string_sifted_left(i2+1:i7),'(i2)') day
1558 
1559  if(i3 == 0) then
1560 ! There are no minutes or seconds in the string
1561  minute = 0
1562  second = 0
1563  tick = 0
1564  if(i5 <= i2+2) then
1565  ! There is no clocktime in the string at all
1566  hour = 0
1567  else
1568  ! The clocktime includes only hours
1569  read(string_sifted_left(i5-1:i5),'(i2)') hour
1570  endif
1571  else if(i3 == i4) then
1572  ! The string includes hours and minutes, but no seconds
1573  read(string_sifted_left(i3-2:i3-1),'(i2)') hour
1574  write(formt(3:3),'(i1)') i5-i3
1575  read(string_sifted_left(i3+1:i5),formt) minute
1576  second = 0
1577  tick = 0
1578  else
1579  ! The string includes hours, minutes, and seconds
1580  read(string_sifted_left(i3-2:i3-1),'(i2)') hour
1581  write(formt(3:3),'(i1)') i4-i3-1
1582  read(string_sifted_left(i3+1:i4-1),formt) minute
1583  write(formt(3:3),'(i1)') i5-i4
1584  if(i6 == 0) then
1585  ! There are no fractional seconds
1586  read(string_sifted_left(i4+1:i5),formt) second
1587  tick = 0
1588  else
1589  read(string_sifted_left(i4+1:i6-1),formt) second
1590  if(.not.get_tick_from_string(string_sifted_left(i6:i5), err_msg_local, allow_rounding_local, tick)) then
1591  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
1592  endif
1593  ! If tick has been rounded up to ticks_per_second, then bump up second.
1594  if(tick == ticks_per_second) then
1595  second = second + 1
1596  tick = 0
1597  endif
1598  endif
1599  endif
1600 
1601  if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local)) then
1602  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
1603  end if
1604 
1605  end function set_date_c
1606 
1607 !------------------------------------------------------------------------
1608 
1609 !> @brief Sets Time_out%days on a Gregorian calendar
1610 !! Computes the total number of days between 1/1/0001 to the current month/day/year
1611  function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1612  logical :: set_date_gregorian
1613 
1614 ! Computes time corresponding to date for gregorian calendar.
1615 
1616  integer, intent(in) :: year, month, day, hour, minute, second, tick
1617  type(time_type), intent(out) :: time_out
1618  character(len=*), intent(out) :: err_msg
1619  integer :: yearx, monthx, dayx, hrx, minx, secx, tickx, ncenturies, nlpyrs, l
1620 
1621  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
1622  set_date_gregorian = .false.
1623  return
1624  endif
1625 
1626  l = 0 ; if( leap_year_gregorian_int(year) ) l = 1
1627 
1628  ! Check if date is invalid
1629  if(month.eq.2) then
1630  if(day.gt.days_per_month(month)+l .or. day.lt.1) then
1631  err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1632  set_date_gregorian = .false.
1633  return
1634  end if
1635  else
1636  if(day.gt.days_per_month(month) .or. day.lt.1) then
1637  err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1638  set_date_gregorian = .false.
1639  return
1640  end if
1641  end if
1642 
1643  time_out%seconds = second + 60*(minute + 60*hour)
1644 
1645  yearx = mod(year-1,400)
1646  dayx = 0
1647  if(yearx.gt.0) then
1648  ncenturies = int( yearx/100 )
1649  nlpyrs = int( (yearx-ncenturies*100)/4 )
1650  dayx = ncenturies*36524 + (yearx-ncenturies*100)*365 + nlpyrs ! 36524 days in 100 years, year 100 not
1651  !! leap year
1652  if(ncenturies.eq.4) dayx = dayx + 1 ! year 400 is a leap year
1653  end if
1654 
1655  select case( month )
1656  case(1) ; dayx = dayx
1657  case(2) ; dayx = dayx + 31
1658  case(3) ; dayx = dayx + 59 + l
1659  case(4) ; dayx = dayx + 90 + l
1660  case(5) ; dayx = dayx + 120 + l
1661  case(6) ; dayx = dayx + 151 + l
1662  case(7) ; dayx = dayx + 181 + l
1663  case(8) ; dayx = dayx + 212 + l
1664  case(9) ; dayx = dayx + 243 + l
1665  case(10) ; dayx = dayx + 273 + l
1666  case(11) ; dayx = dayx + 304 + l
1667  case(12) ; dayx = dayx + 334 + l
1668  end select
1669 
1670  dayx = int((year-1)/400)*days_in_400_year_period + dayx + day - 1
1671  time_out%days = dayx
1672  time_out%ticks = tick
1673 
1674  err_msg = ''
1675  set_date_gregorian = .true.
1676 
1677  ! check
1678  yearx = year ; monthx = month ; dayx = day
1679  hrx = hour ; minx = minute ; secx = second ; tickx = tick
1680  call get_date_gregorian(time_out, yearx, monthx, dayx, hrx, minx, secx, tickx)
1681  l = 0 ; if( leap_year_gregorian_int(yearx) ) l = 1
1682  if( monthx.lt.1 .or. monthx.gt.12 ) then
1683  err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(yearx,monthx,dayx,hour,minute,second)
1684  set_date_gregorian = .false.
1685  else if( dayx.lt.1 .or. dayx.gt.days_per_month(monthx) ) then
1686  if( monthx.eq.2 .and. dayx.le.days_per_month(monthx)+l ) return
1687  err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(yearx,monthx,dayx,hour,minute,second)
1688  set_date_gregorian = .false.
1689  end if
1690 
1691  end function set_date_gregorian
1692 
1693 !------------------------------------------------------------------------
1694 
1695  function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1696  logical :: set_date_julian_private
1697 
1698 ! Returns time corresponding to date for julian calendar.
1699 
1700  integer, intent(in) :: year, month, day, hour, minute, second, tick
1701  type(time_type), intent(out) :: time_out
1702  character(len=*), intent(out) :: err_msg
1703  integer :: ndays, m, nleapyr
1704  logical :: leap
1705 
1706  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
1707  set_date_julian_private = .false.
1708  return
1709  endif
1710 
1711  if(month /= 2 .and. day > days_per_month(month)) then
1712  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1713  set_date_julian_private = .false.
1714  return
1715  endif
1716 
1717 ! Is this a leap year?
1718  leap = (modulo(year,4) == 0)
1719 ! compute number of complete leap years from year 1
1720  nleapyr = (year - 1) / 4
1721 
1722 ! Finish checking for day specication errors
1723  if(month == 2 .and. (day > 29 .or. ((.not. leap) .and. day > 28))) then
1724  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1725  set_date_julian_private = .false.
1726  return
1727  endif
1728 
1729  ndays = 0
1730  do m = 1, month - 1
1731  ndays = ndays + days_per_month(m)
1732  if(leap .and. m == 2) ndays = ndays + 1
1733  enddo
1734 
1735  time_out%seconds = second + 60 * (minute + 60 * hour)
1736  time_out%days = day -1 + ndays + 365*(year - nleapyr - 1) + 366*(nleapyr)
1737  time_out%ticks = tick
1738  err_msg = ''
1739  set_date_julian_private = .true.
1740 
1741  end function set_date_julian_private
1742 
1743 !------------------------------------------------------------------------
1744  function set_date_julian(year, month, day, hour, minute, second)
1745 
1746 ! No need to include tick or err_msg in argument list because this
1747 ! routine exists only for interpolator.F90, which does not need them.
1748 
1749  type(time_type) :: set_date_julian
1750  integer, intent(in) :: year, month, day, hour, minute, second
1751  character(len=128) :: err_msg
1752 
1753  if(.not.set_date_julian_private(year, month, day, hour, minute, second, 0, set_date_julian, err_msg)) then
1754  call error_mesg('set_date_julian',trim(err_msg),fatal)
1755  endif
1756 
1757  end function set_date_julian
1758 !------------------------------------------------------------------------
1759 
1760  function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1761  logical :: set_date_thirty
1762 
1763 ! Computes time corresponding to date for thirty day months.
1764 
1765  integer, intent(in) :: year, month, day, hour, minute, second, tick
1766  type(time_type), intent(out) :: time_out
1767  character(len=*), intent(out) :: err_msg
1768 
1769  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
1770  set_date_thirty = .false.
1771  return
1772  endif
1773 
1774  if(day > 30) then
1775  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1776  set_date_thirty = .false.
1777  return
1778  endif
1779 
1780  time_out%days = (day - 1) + 30 * ((month - 1) + 12 * (year - 1))
1781  time_out%seconds = second + 60 * (minute + 60 * hour)
1782  time_out%ticks = tick
1783  err_msg = ''
1784  set_date_thirty = .true.
1785 
1786  end function set_date_thirty
1787 
1788 !------------------------------------------------------------------------
1789 
1790  function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1791  logical :: set_date_no_leap_private
1792 
1793 ! Computes time corresponding to date for fixed 365 day year calendar.
1794 
1795  integer, intent(in) :: year, month, day, hour, minute, second, tick
1796  type(time_type), intent(out) :: time_out
1797  character(len=*), intent(out) :: err_msg
1798  integer :: ndays, m
1799 
1800  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
1801  set_date_no_leap_private = .false.
1802  return
1803  endif
1804 
1805  if(day > days_per_month(month)) then
1806  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1807  set_date_no_leap_private = .false.
1808  return
1809  endif
1810 
1811  ndays = 0
1812  do m = 1, month - 1
1813  ndays = ndays + days_per_month(m)
1814  enddo
1815 
1816 ! No need for err_msg in call to set_time because previous checks ensure positive value of time.
1817  time_out = set_time(second + 60 * (minute + 60 * hour), day -1 + ndays + 365 * (year - 1), tick)
1818  err_msg = ''
1819  set_date_no_leap_private = .true.
1820 
1821  end function set_date_no_leap_private
1822 !------------------------------------------------------------------------
1823 
1824  function set_date_no_leap(year, month, day, hour, minute, second)
1825 
1826 ! No need to include tick or err_msg in argument list because this
1827 ! routine exists only for interpolator.F90, which does not need them.
1828 
1829  type(time_type) :: set_date_no_leap
1830  integer, intent(in) :: year, month, day, hour, minute, second
1831  character(len=128) :: err_msg
1832 
1833  if(.not.set_date_no_leap_private(year, month, day, hour, minute, second, 0, set_date_no_leap, err_msg)) then
1834  call error_mesg('set_date_no_leap',trim(err_msg),fatal)
1835  endif
1836 
1837  end function set_date_no_leap
1838 
1839 !=========================================================================
1840 
1841  function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
1842  logical :: valid_increments
1843  integer, intent(in) :: year, month, day, hour, minute, second, tick
1844  character(len=128), intent(out) :: err_msg
1845 
1846 ! Check for invalid values
1847 
1848  err_msg = ''
1849  valid_increments = .true.
1850  if(second > 59 .or. second < 0 .or. minute > 59 .or. minute < 0 &
1851  .or. hour > 23 .or. hour < 0 .or. day > 31 .or. day < 1 &
1852  .or. month > 12 .or. month < 1 .or. year < 1) then
1853  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
1854  valid_increments = .false.
1855  return
1856  endif
1857  if(tick < 0 .or. tick >= ticks_per_second) then
1858  write(err_msg,'(a,i6)') 'Invalid number of ticks. tick=',tick
1859  valid_increments = .false.
1860  endif
1861 
1862  end function valid_increments
1863 
1864 !=========================================================================
1865 
1866  function convert_integer_date_to_char(year, month, day, hour, minute, second)
1867  character(len=19) :: convert_integer_date_to_char
1868  integer, intent(in) :: year, month, day
1869  integer, intent(in) :: hour, minute, second
1870 
1871  write(convert_integer_date_to_char,10) year,month,day,hour,minute,second
1872  10 format(i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
1873 
1874  end function convert_integer_date_to_char
1875 
1876 !=========================================================================
1877 ! END OF set_date BLOCK
1878 !=========================================================================
1879 
1880 ! <FUNCTION NAME="increment_date">
1881 
1882 ! <OVERVIEW>
1883 ! Increments the date represented by a time interval and the
1884 ! default calendar type by a number of seconds, etc.
1885 ! </OVERVIEW>
1886 ! <DESCRIPTION>
1887 ! Given a time and some date increment, computes a new time. Depending
1888 ! on the mapping algorithm from date to time, it may be possible to specify
1889 ! undefined increments (i.e. if one increments by 68 days and 3 months in
1890 ! a Julian calendar, it matters which order these operations are done and
1891 ! we don't want to deal with stuff like that, make it an error).
1892 ! </DESCRIPTION>
1893 ! <TEMPLATE>
1894 ! increment_date(time, years, months, days, hours, minutes, seconds, ticks, err_msg)
1895 ! </TEMPLATE>
1896 ! <IN NAME="time" TYPE="time_type"> A time interval.</IN>
1897 ! <IN NAME="years" TYPE="integer">An increment of years.</IN>
1898 ! <IN NAME="months" TYPE="integer">An increment of months.</IN>
1899 ! <IN NAME="days" TYPE="integer">An increment of days.</IN>
1900 ! <IN NAME="hours" TYPE="integer">An increment of hours.</IN>
1901 ! <IN NAME="minutes" TYPE="integer">An increment of minutes.</IN>
1902 ! <IN NAME="seconds" TYPE="integer">An increment of seconds.</IN>
1903 ! <IN NAME="ticks" TYPE="integer">An increment of ticks.</IN>
1904 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1905 ! When present, and when non-blank, a fatal error condition as been detected.
1906 ! The string itself is an error message.
1907 ! It is recommended that, when err_msg is present in the call
1908 ! to this routine, the next line of code should be something
1909 ! similar to this:
1910 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1911 ! </OUT>
1912 ! <OUT NAME="increment_date" TYPE="time_type"> A new time based on the input
1913 ! time interval and the calendar type.
1914 ! </OUT>
1915 ! <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
1916 ! When .false., it is a fatal error if any of the input time increments are negative.
1917 ! This mimics the behavior of lima and earlier revisions.
1918 ! </IN>
1919 ! <NOTE>
1920 ! For all but the thirty_day_months calendar, increments to months
1921 ! and years must be made separately from other units because of the
1922 ! non-associative nature of addition.
1923 ! If the result is a negative time (i.e. date before the base date)
1924 ! it is considered a fatal error.
1925 ! </NOTE>
1926 
1927  function increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
1928 
1929 ! Given a time and some date increment, computes a new time. Depending
1930 ! on the mapping algorithm from date to time, it may be possible to specify
1931 ! undefined increments (i.e. if one increments by 68 days and 3 months in
1932 ! a Julian calendar, it matters which order these operations are done and
1933 ! we don't want to deal with stuff like that, make it an error).
1934 
1935 ! This routine operates in one of two modes.
1936 ! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
1937 ! 2. years and/or months are incremented, other time increments must be zero or absent arguments.
1938 
1939  type(time_type) :: increment_date
1940  type(time_type), intent(in) :: time
1941  integer, intent(in), optional :: years, months, days, hours, minutes, seconds, ticks
1942  character(len=*), intent(out), optional :: err_msg
1943  logical, intent(in), optional :: allow_neg_inc
1944 
1945  integer :: oyears, omonths, odays, ohours, ominutes, oseconds, oticks
1946  character(len=128) :: err_msg_local
1947  logical :: allow_neg_inc_local
1948 
1949  if(.not.module_is_initialized) call time_manager_init
1950  if(present(err_msg)) err_msg = ''
1951 
1952 ! Missing optionals are set to 0
1953  oseconds = 0; if(present(seconds)) oseconds = seconds
1954  ominutes = 0; if(present(minutes)) ominutes = minutes
1955  ohours = 0; if(present(hours)) ohours = hours
1956  odays = 0; if(present(days)) odays = days
1957  omonths = 0; if(present(months)) omonths = months
1958  oyears = 0; if(present(years)) oyears = years
1959  oticks = 0; if(present(ticks)) oticks = ticks
1960  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
1961 
1962  if(.not.allow_neg_inc_local) then
1963  if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. &
1964  & oticks < 0) then
1965  write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
1966  if(error_handler('function increment_time', err_msg_local, err_msg)) return
1967  endif
1968  endif
1969  10 format('One or more time increments are negative: '// &
1970  'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)
1971 
1972  if(.not.increment_date_private( &
1973  time, oyears, omonths, odays, ohours, ominutes, oseconds, oticks, increment_date, err_msg_local)) then
1974  if(error_handler('function increment_date', err_msg_local, err_msg)) return
1975  endif
1976 
1977  end function increment_date
1978 
1979 !=======================================================================
1980 
1981  !> Given a time and some date increment, computes a new time. Depending
1982  !! on the mapping algorithm from date to time, it may be possible to specify
1983  !! undefined increments (i.e. if one increments by 68 days and 3 months in
1984  !! a Julian calendar, it matters which order these operations are done and
1985  !! we don't want to deal with stuff like that, make it an error).
1986  !!
1987  !! This routine operates in one of two modes.
1988  !! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
1989  !! 2. years and/or months are incremented, other time increments must be zero or absent arguments.
1990  !!
1991  !! Negative increments are always allowed in the private version of this routine.
1992  function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
1993 
1994 
1995  logical :: increment_date_private
1996  type(time_type), intent(in) :: time
1997  integer, intent(in) :: years, months, days, hours, minutes, seconds, ticks
1998  type(time_type), intent(out) :: time_out
1999  character(len=*), intent(out) :: err_msg
2000  integer :: cyear , cmonth , cday , chour , cminute , csecond , ctick
2001  logical :: mode_1, mode_2
2002 
2003  err_msg = ''
2004  increment_date_private = .true.
2005 
2006  mode_1 = days /= 0 .or. hours /= 0 .or. minutes /= 0 .or. seconds /= 0 .or. ticks /= 0
2007  mode_2 = years /= 0 .or. months /= 0
2008 
2009  if(.not.mode_1 .and. .not.mode_2) then
2010  ! All time increments are zero
2011  time_out = time
2012  return
2013  endif
2014 
2015  if(mode_1 .and. mode_2) then
2016  err_msg = 'years and/or months must not be incremented with other time units'
2017  increment_date_private = .false.
2018  return
2019  endif
2020 
2021  if(mode_1) then
2022  csecond = seconds + 60 * (minutes + 60 * hours)
2023  increment_date_private = increment_time_private(time, csecond, days, ticks, time_out, err_msg)
2024  endif
2025 
2026  if(mode_2) then
2027  ! Convert Time to a date
2028  select case(calendar_type)
2029  case(thirty_day_months)
2030  call get_date_thirty (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2031  case(noleap)
2032  call get_date_no_leap_private (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2033  case(julian)
2034  call get_date_julian_private (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2035  case(gregorian)
2036  call get_date_gregorian(time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2037  case(no_calendar)
2038  err_msg = 'Cannot increment a date when the calendar type is NO_CALENDAR'
2039  increment_date_private = .false.
2040  return
2041  case default
2042  err_msg = 'Invalid calendar type'
2043  increment_date_private = .false.
2044  return
2045  end select
2046 
2047  ! Add month increment
2048  cmonth = cmonth + months
2049 
2050  ! Adjust year and month number when cmonth falls outside the range 1 to 12
2051  cyear = cyear + floor(real(cmonth-1,r8_kind)/12.0_r8_kind)
2052  cmonth = modulo((cmonth-1),12) + 1
2053 
2054  ! Add year increment
2055  cyear = cyear + years
2056 
2057  ! Convert this back into a time.
2058  select case(calendar_type)
2059  case(thirty_day_months)
2060  increment_date_private = set_date_thirty(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, err_msg)
2061  case(noleap)
2062  increment_date_private = set_date_no_leap_private(cyear, cmonth, cday, chour, cminute, csecond, ctick, &
2063  & time_out, err_msg)
2064  case(julian)
2065  increment_date_private = set_date_julian_private(cyear, cmonth, cday, chour, cminute, csecond, ctick, &
2066  & time_out, err_msg)
2067  case(gregorian)
2068  increment_date_private = set_date_gregorian(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, &
2069  & err_msg)
2070  end select
2071  endif ! if(mode_2)
2072 
2073  end function increment_date_private
2074 
2075 !=========================================================================
2076 
2077  !> Given a time and some date decrement, computes a new time. Depending
2078  !! on the mapping algorithm from date to time, it may be possible to specify
2079  !! undefined decrements (i.e. if one decrements by 68 days and 3 months in
2080  !! a Julian calendar, it matters which order these operations are done and
2081  !! we don't want to deal with stuff like that, make it an error).
2082  !!
2083  !! @note For all but the thirty_day_months calendar, decrements to months
2084  !! and years must be made separately from other units because of the
2085  !! non-associative nature of addition.
2086  !! If the result is a negative time (i.e. date before the base date)
2087  !! it is considered a fatal error.
2088  function decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
2089 
2090  type(time_type) :: decrement_date !< Time after the given decrement is applied
2091  type(time_type), intent(in) :: time !< time interval to decrement
2092  integer, intent(in), optional :: seconds, minutes, hours, days, months, years, ticks !< amount of time to decrement by
2093  !! units should not exceed next largest unit (ie. 61 seconds
2094  !! should be 1 min 1 sec )
2095  character(len=*), intent(out), optional :: err_msg
2096  logical, intent(in), optional :: allow_neg_inc
2097 
2098  integer :: oseconds, ominutes, ohours, odays, omonths, oyears, oticks
2099  character(len=128) :: err_msg_local
2100  logical :: allow_neg_inc_local
2101 
2102  if(present(err_msg)) err_msg = ''
2103 
2104  ! Missing optionals are set to 0
2105  oseconds = 0; if(present(seconds)) oseconds = seconds
2106  ominutes = 0; if(present(minutes)) ominutes = minutes
2107  ohours = 0; if(present(hours)) ohours = hours
2108  odays = 0; if(present(days)) odays = days
2109  omonths = 0; if(present(months)) omonths = months
2110  oyears = 0; if(present(years)) oyears = years
2111  oticks = 0; if(present(ticks)) oticks = ticks
2112  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
2113 
2114  if(.not.allow_neg_inc_local) then
2115  if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. &
2116  & oticks < 0) then
2117  write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2118  if(error_handler('function decrement_date', err_msg_local, err_msg)) return
2119  endif
2120  endif
2121  10 format('One or more time increments are negative: '// &
2122  'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)
2123 
2124  if(.not.increment_date_private( &
2125  time, -oyears, -omonths, -odays, -ohours, -ominutes, -oseconds, -oticks, decrement_date, err_msg_local)) then
2126  if(error_handler('function decrement_date', err_msg_local, err_msg)) return
2127  endif
2128 
2129  end function decrement_date
2130 
2131 !--------------------------------------------------------------------------
2132 
2133 !> Given a time, computes the corresponding date given the selected
2134 !! date time mapping algorithm
2135 function days_in_month(Time, err_msg)
2136 integer :: days_in_month !< number of days in month given the current selected calendar type
2137 type(time_type), intent(in) :: time !< a time interval
2138 character(len=*), intent(out), optional :: err_msg
2139 
2140 if(.not.module_is_initialized) call time_manager_init
2141 if(present(err_msg)) err_msg = ''
2142 
2143 select case(calendar_type)
2144 case(thirty_day_months)
2146 case(gregorian)
2148 case(julian)
2150 case(noleap)
2152 case(no_calendar)
2153  if(error_handler('function days_in_month', &
2154  'days_in_month makes no sense when the calendar type is NO_CALENDAR', err_msg)) return
2155 case default
2156  if(error_handler('function days_in_month', 'Invalid calendar type', err_msg)) return
2157 end select
2158 end function days_in_month
2159 
2160 !--------------------------------------------------------------------------
2161 
2162 !> Returns the number of days in a gregorian month.
2164 integer :: days_in_month_gregorian
2165 type(time_type), intent(in) :: time
2166 integer :: year, month, day, hour, minute, second, ticks
2167 
2168 call get_date_gregorian(time, year, month, day, hour, minute, second, ticks)
2169 days_in_month_gregorian = days_per_month(month)
2170 if(leap_year_gregorian_int(year) .and. month == 2) days_in_month_gregorian = 29
2171 
2172 end function days_in_month_gregorian
2173 
2174 !--------------------------------------------------------------------------
2175 
2176 !> Returns the number of days in a julian month.
2177 function days_in_month_julian(Time)
2178 integer :: days_in_month_julian
2179 type(time_type), intent(in) :: time
2180 integer :: year, month, day, hour, minute, second, ticks
2181 
2182 call get_date_julian_private(time, year, month, day, hour, minute, second, ticks)
2183 days_in_month_julian = days_per_month(month)
2184 if(leap_year_julian(time) .and. month == 2) days_in_month_julian = 29
2185 
2186 end function days_in_month_julian
2187 
2188 !--------------------------------------------------------------------------
2189 
2190 !> Returns the number of days in a thirty day month (needed for transparent
2191 !! changes to calendar type).
2192 function days_in_month_thirty(Time)
2193 integer :: days_in_month_thirty
2194 type(time_type), intent(in) :: time
2195 
2197 
2198 end function days_in_month_thirty
2199 
2200 !--------------------------------------------------------------------------
2201 
2202 !> Returns the number of days in a 365 day year month.
2204 integer :: days_in_month_no_leap
2205 type(time_type), intent(in) :: time
2206 integer :: year, month, day, hour, minute, second, ticks
2207 
2208 call get_date_no_leap_private(time, year, month, day, hour, minute, second, ticks)
2209 days_in_month_no_leap= days_per_month(month)
2210 
2211 end function days_in_month_no_leap
2212 
2213 !> Returns true if the year corresponding to the input time is
2214 !! a leap year (for default calendar). Always returns false for THIRTY_DAY_MONTHS and NOLEAP.
2215 function leap_year(Time, err_msg)
2216 logical :: leap_year
2217 type(time_type), intent(in) :: time !< a time interval to check if leap year
2218 character(len=*), intent(out), optional :: err_msg
2219 
2220 if(.not.module_is_initialized) call time_manager_init
2221 if(present(err_msg)) err_msg=''
2222 
2223 select case(calendar_type)
2224 case(thirty_day_months)
2225  leap_year = leap_year_thirty(time)
2226 case(gregorian)
2227  leap_year = leap_year_gregorian(time)
2228 case(julian)
2229  leap_year = leap_year_julian(time)
2230 case(noleap)
2232 case default
2233  if(error_handler('function leap_year', 'Invalid calendar type in leap_year', err_msg)) return
2234 end select
2235 end function leap_year
2236 
2237 !--------------------------------------------------------------------------
2238 
2239 function leap_year_gregorian(Time)
2240 
2241 ! Is this a leap year for gregorian calendar?
2242 
2243 logical :: leap_year_gregorian
2244 type(time_type), intent(in) :: time
2245 integer :: seconds, minutes, hours, day, month, year
2246 
2247 call get_date(time, year, month, day, hours, minutes, seconds)
2248 leap_year_gregorian = leap_year_gregorian_int(year)
2249 
2250 end function leap_year_gregorian
2251 
2252 !--------------------------------------------------------------------------
2253 
2254 function leap_year_gregorian_int(year)
2255 logical :: leap_year_gregorian_int
2256 integer, intent(in) :: year
2257 
2258 leap_year_gregorian_int = mod(year,4) == 0
2259 leap_year_gregorian_int = leap_year_gregorian_int .and. .not.mod(year,100) == 0
2260 leap_year_gregorian_int = leap_year_gregorian_int .or. mod(year,400) == 0
2261 
2262 end function leap_year_gregorian_int
2263 
2264 !--------------------------------------------------------------------------
2265 
2266 !> Returns the number of days in a julian month.
2267 function leap_year_julian(Time)
2268 logical :: leap_year_julian
2269 type(time_type), intent(in) :: time
2270 integer :: seconds, minutes, hours, day, month, year
2271 
2272 call get_date(time, year, month, day, hours, minutes, seconds)
2273 leap_year_julian = ((year / 4 * 4) == year)
2274 
2275 end function leap_year_julian
2276 
2277 !--------------------------------------------------------------------------
2278 
2279 !> No leap years in thirty day months, included for transparency.
2280 function leap_year_thirty(Time)
2281 logical :: leap_year_thirty
2282 type(time_type), intent(in) :: time
2283 
2284 leap_year_thirty = .false.
2285 
2286 end function leap_year_thirty
2287 
2288 !--------------------------------------------------------------------------
2289 
2290 !> Another tough one; no leap year returns false for leap year inquiry.
2291 function leap_year_no_leap(Time)
2292 logical :: leap_year_no_leap
2293 type(time_type), intent(in) :: time
2294 
2295 leap_year_no_leap = .false.
2296 
2297 end function leap_year_no_leap
2298 
2299 !> @brief Returns the mean length of the year in the default calendar setting.
2300 !!
2301 !> There are no arguments in this function. It returns the mean
2302 !! length of the year for the default calendar.
2303 function length_of_year()
2304 ! What is the length of the year for the default calendar type
2305 
2306 type(time_type) :: length_of_year
2307 
2308 if(.not.module_is_initialized) call time_manager_init
2309 
2310 select case(calendar_type)
2311 case(thirty_day_months)
2312  length_of_year = length_of_year_thirty()
2313 case(gregorian)
2314  length_of_year = length_of_year_gregorian()
2315 case(julian)
2316  length_of_year = length_of_year_julian()
2317 case(noleap)
2318  length_of_year = length_of_year_no_leap()
2319 case default
2320  call error_mesg('length_of_year','Invalid calendar type in length_of_year',fatal)
2321 end select
2322 end function length_of_year
2323 
2324 !--------------------------------------------------------------------------
2325 
2326 function length_of_year_thirty()
2327 
2328 type(time_type) :: length_of_year_thirty
2329 
2330 length_of_year_thirty = set_time(0, 360)
2331 
2332 end function length_of_year_thirty
2333 
2334 !---------------------------------------------------------------------------
2335 
2336 function length_of_year_gregorian()
2337 
2338 type(time_type) :: length_of_year_gregorian
2339 
2340 length_of_year_gregorian = set_time(20952, 365) !20952 = 86500 * (days_in_400_yrs/400. - (days_in_400_yrs/400))
2341 
2342 end function length_of_year_gregorian
2343 
2344 !--------------------------------------------------------------------------
2345 
2346 function length_of_year_julian()
2347 
2348 type(time_type) :: length_of_year_julian
2349 
2350 length_of_year_julian = set_time(21600, 365) !21600 = (24/4) * 60 * 60
2351 
2352 end function length_of_year_julian
2353 
2354 !--------------------------------------------------------------------------
2355 
2356 function length_of_year_no_leap()
2357 
2358 type(time_type) :: length_of_year_no_leap
2359 
2360 length_of_year_no_leap = set_time(0, 365)
2361 
2362 end function length_of_year_no_leap
2363 
2364 !--------------------------------------------------------------------------
2365 
2366 !> Returns number of day in year for given time. Jan 1st is day 1, not zero!
2367 function day_of_year(time)
2368  integer :: day_of_year
2369  type(time_type), intent(in) :: time
2370 
2371  integer :: second, minute, hour, day, month, year
2372  type(time_type) :: t
2373 
2374  call get_date(time,year,month,day,hour,minute,second)
2375  t = time-set_date(year,1,1,0,0,0)
2376  day_of_year = t%days + 1
2377 end
2378 
2379 !> @brief Returns the number of days in the calendar year corresponding to the date represented by
2380 !! time for the default calendar.
2381 !> @returns The number of days in this year for the default calendar type.
2382 function days_in_year(Time)
2383 
2384 ! What is the number of days in this year for the default calendar type
2385 
2386 integer :: days_in_year
2387 type(time_type), intent(in) :: time !< A time interval
2388 
2389 if(.not.module_is_initialized) call time_manager_init
2390 
2391 select case(calendar_type)
2392 case(thirty_day_months)
2393  days_in_year = days_in_year_thirty(time)
2394 case(gregorian)
2395  days_in_year = days_in_year_gregorian(time)
2396 case(julian)
2397  days_in_year = days_in_year_julian(time)
2398 case(noleap)
2399  days_in_year = days_in_year_no_leap(time)
2400 case default
2401  call error_mesg('days_in_year','Invalid calendar type in days_in_year',fatal)
2402 end select
2403 end function days_in_year
2404 
2405 !--------------------------------------------------------------------------
2406 
2407 function days_in_year_thirty(Time)
2408 
2409 integer :: days_in_year_thirty
2410 type(time_type), intent(in) :: time
2411 
2412 days_in_year_thirty = 360
2413 
2414 end function days_in_year_thirty
2415 
2416 !---------------------------------------------------------------------------
2417 
2418 function days_in_year_gregorian(Time)
2419 
2420 integer :: days_in_year_gregorian
2421 type(time_type), intent(in) :: time
2422 
2423 if(leap_year_gregorian(time)) then
2424  days_in_year_gregorian = 366
2425 else
2426  days_in_year_gregorian = 365
2427 endif
2428 
2429 end function days_in_year_gregorian
2430 
2431 !--------------------------------------------------------------------------
2432 function days_in_year_julian(Time)
2433 
2434 integer :: days_in_year_julian
2435 type(time_type), intent(in) :: time
2436 
2437 if(leap_year_julian(time)) then
2438  days_in_year_julian = 366
2439 else
2440  days_in_year_julian = 365
2441 endif
2442 
2443 end function days_in_year_julian
2444 
2445 !--------------------------------------------------------------------------
2446 
2447 function days_in_year_no_leap(Time)
2448 
2449 integer :: days_in_year_no_leap
2450 type(time_type), intent(in) :: time
2451 
2452 days_in_year_no_leap = 365
2453 
2454 end function days_in_year_no_leap
2455 
2456 !--------------------------------------------------------------------------
2457 
2458 !> @brief Returns a character string containing the name of the
2459 !! month corresponding to month number n.
2460 !!
2461 !> Definition is the same for all calendar types.
2462 !! @returns The character string associated with a month. All calendars have 12 months and return
2463 !! full month names, not abreviations.
2464 function month_name(n)
2465 
2466 ! Returns character string associated with a month, for now, all calendars
2467 ! have 12 months and will return standard names.
2468 
2469 character (len=9) :: month_name
2470 integer, intent(in) :: n !< Month number
2471 character (len = 9), dimension(12) :: months = (/'January ', 'February ', &
2472  'March ', 'April ', 'May ', 'June ', 'July ', &
2473  'August ', 'September', 'October ', 'November ', 'December '/)
2474 
2475 if(.not.module_is_initialized) call time_manager_init
2476 
2477 if(n < 1 .or. n > 12) call error_mesg('month_name','Illegal month index',fatal)
2478 
2479 month_name = months(n)
2480 
2481 end function month_name
2482 
2483 !==========================================================================
2484 
2485 !> The purpose of this routine is to prevent the addition of an excessive amount of code in order to implement
2486 !! the error handling scheme involving an optional error flag of type character.
2487 !! It allows one line of code to accomplish what would otherwise require 6 lines.
2488 !! A value of .true. for this function is a flag to the caller that it should immediately return to it's caller.
2489  function error_handler(routine, err_msg_local, err_msg)
2490 
2491 
2492  logical :: error_handler
2493  character(len=*), intent(in) :: routine, err_msg_local
2494  character(len=*), intent(out), optional :: err_msg
2495 
2496  error_handler = .false.
2497  if(present(err_msg)) then
2498  err_msg = err_msg_local
2499  error_handler = .true.
2500  else
2501  call error_mesg(trim(routine),trim(err_msg_local),fatal)
2502  endif
2503 
2504  end function error_handler
2505 
2506 !------------------------------------------------------------------------
2507 
2508 !> Initialization routine. Writes the version information to the log file
2509 subroutine time_manager_init ( )
2510 
2511  if (module_is_initialized) return ! silent return if already called
2512 
2513  call write_version_number("TIME_MANAGER_MOD", version)
2514  module_is_initialized = .true.
2515 
2516 end subroutine time_manager_init
2517 
2518 !------------------------------------------------------------------------
2519 
2520 !> @brief Prints the given time_type argument as a time (using days, seconds and ticks)
2521 !!
2522 !> @note There is no check for PE number.
2523 subroutine print_time (Time,str,unit)
2524 type(time_type) , intent(in) :: time !< Time that will be printed
2525 character (len=*), intent(in), optional :: str !< Character string that precedes the printed time
2526 integer , intent(in), optional :: unit !< Unit number for printed output, defaults to stdout
2527 integer :: s,d,ticks, ns,nd,nt, unit_in
2528 character(len=19) :: fmt
2529 
2530 ! prints the time to standard output (or optional unit) as days and seconds
2531 ! NOTE: there is no check for PE number
2532 
2533  unit_in = stdout()
2534  if (present(unit)) unit_in = unit
2535 
2536  call get_time (time,s,d,ticks)
2537 
2538 ! format output
2539 ! get number of digits for days and seconds strings
2540  nd = int(log10(real(max(1,d))))+1
2541  ns = int(log10(real(max(1,s))))+1
2542  nt = int(log10(real(max(1,ticks))))+1
2543  write (fmt,10) nd, ns, nt
2544 10 format ('(a,i',i2.2,',a,i',i2.2,',a,i',i2.2,')')
2545 
2546  if (present(str)) then
2547  write (unit_in,fmt) trim(str)//' day=', d, ', sec=', s, ', ticks=', ticks
2548  else
2549  write (unit_in,fmt) 'TIME: day=', d, ', sec=', s, ', ticks=', ticks
2550  endif
2551 
2552 end subroutine print_time
2553 
2554 !> @brief Prints the time to standard output (or optional unit) as a date.
2555 !!
2556 !! Prints the given time_type argument as a date (using year, month, day,
2557 !! hour, minutes, seconds and ticks). NOTE: there is no check for PE number.
2558 subroutine print_date (Time,str,unit)
2559 type(time_type) , intent(in) :: time !< Time that will be printed
2560 character (len=*), intent(in), optional :: str !< Character string that precedes the printed time
2561 integer , intent(in), optional :: unit !< Unit number for printed output, defaults to stdout
2562 integer :: y,mo,d,h,m,s, unit_in
2563 character(len=9) :: mon
2564 
2565 ! prints the time to standard output (or optional unit) as a date
2566 ! NOTE: there is no check for PE number
2567 
2568  unit_in = stdout()
2569  if (present(unit)) unit_in = unit
2570 
2571  call get_date (time,y,mo,d,h,m,s)
2572  mon = month_name(mo)
2573  if (present(str)) then
2574  write (unit_in,10) trim(str)//' ', y,mon(1:3),' ',d,' ',h,':',m,':',s
2575  else
2576  write (unit_in,10) 'DATE: ', y,mon(1:3),' ',d,' ',h,':',m,':',s
2577  endif
2578 10 format (a,i4,1x,a3,4(a1,i2.2))
2579 
2580 end subroutine print_date
2581 
2582 !------------------------------------------------------------------------
2583 
2584 !> @brief Returns a character string that describes the
2585 !! calendar type corresponding to the input integer.
2586 !!
2587 !> @returns A character string describing the calendar type
2588 function valid_calendar_types(ncal, err_msg)
2589 integer, intent(in) :: ncal !< Integer corresponding to a valid calendar type
2590 character(len=*), intent(out), optional :: err_msg !< Holds an error message when present
2591 character(len=24) :: valid_calendar_types
2592 character(len=128) :: err_msg_local
2593 
2594 if(.not.module_is_initialized) call time_manager_init
2595 
2596 if(present(err_msg)) err_msg = ''
2597 
2598 if(ncal == no_calendar) then
2599  valid_calendar_types = 'NO_CALENDAR '
2600 else if(ncal == thirty_day_months) then
2601  valid_calendar_types = '360_DAY '
2602 else if(ncal == julian) then
2603  valid_calendar_types = 'JULIAN '
2604 else if(ncal == gregorian) then
2605  valid_calendar_types = 'GREGORIAN '
2606 else if(ncal == noleap) then
2607  valid_calendar_types = 'NOLEAP '
2608 else
2609  write(err_msg_local,'(a,i4,a)') 'calendar type=',ncal,' is invalid.'
2610  if(error_handler('function valid_calendar_types', err_msg_local, err_msg)) return
2611 endif
2612 end function valid_calendar_types
2613 
2614 !------------------------------------------------------------------------
2615 
2616 !> Get the a character string that represents the time. The format will be
2617 !! yyyymmdd.hhmmss
2618 function date_to_string(time, err_msg)
2619  type(time_type), intent(in) :: time
2620  character(len=*), intent(out), optional :: err_msg
2621  character(len=128) :: err_msg_local
2622  character(len=15) :: date_to_string
2623  integer :: yr,mon,day,hr,min,sec
2624 
2625  if(present(err_msg)) err_msg = ''
2626  call get_date(time,yr,mon,day,hr,min,sec)
2627  if (yr <= 9999) then
2628  write(date_to_string,'(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec
2629  else
2630  write(err_msg_local, '(a,i4.4,a)') 'year = ', yr, ' should be less than 10000'
2631  if(error_handler('function date_to_string', err_msg_local, err_msg)) return
2632  endif
2633 
2634 end function date_to_string
2635 
2636 !> \author Tom Robinson thomas.robinson@noaa.gov
2637 !! \brief This routine converts the integer t%days to a string
2638 subroutine time_list_error (T,Terr)
2639  type(time_type), intent(in) :: t !< time_type input
2640  character(len=:), allocatable :: terr !< String holding the t%days
2641 !> Allocate the string
2642  allocate (character(len=10) :: terr)
2643 !> Write the integer to the string
2644  write (terr,'(I0)') t%days
2645 end subroutine time_list_error
2646 
2647 end module time_manager_mod
subroutine, public write_version_number(version, tag, unit)
Prints to the log file (or a specified unit) the version id string and tag name.
Definition: fms.F90:701
subroutine, public error_mesg(routine, message, level)
Print notes, warnings and error messages; terminates program for warning and error messages....
Definition: fms.F90:441
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
type(time_type) function, public length_of_year()
Returns the mean length of the year in the default calendar setting.
integer function, public get_ticks_per_second()
Returns the number of ticks per second.
integer function days_in_month_gregorian(Time)
Returns the number of days in a gregorian month.
logical function, public leap_year(Time, err_msg)
Returns true if the year corresponding to the input time is a leap year (for default calendar)....
type(time_type) function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
Calls set_date_private to set days for different calendar types.
integer function, public day_of_year(time)
Returns number of day in year for given time. Jan 1st is day 1, not zero!
type(time_type) function, public decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
Decrements a time by seconds and days.
type(time_type) function set_time_c(string, err_msg, allow_rounding)
Returns a time_type set to the given amount of time via a string.
type(time_type) function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
Calls set_date_private for different calendar types when given a string input. Examples of acceptable...
type(time_type) function time_scalar_divide(time, n)
Returns the largest time, t, for which n * t <= time.
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
Returns days and seconds ( < 86400 ) corresponding to a time. err_msg should be checked for any error...
type(time_type) function time_scalar_mult(time, n)
Returns time multiplied by integer factor n.
logical function leap_year_thirty(Time)
No leap years in thirty day months, included for transparency.
character(len=15) function, public date_to_string(time, err_msg)
Get the a character string that represents the time. The format will be yyyymmdd.hhmmss.
subroutine, public set_ticks_per_second(tps)
Sets the number of ticks per second.
character(len=24) function, public valid_calendar_types(ncal, err_msg)
Returns a character string that describes the calendar type corresponding to the input integer.
type(time_type) function, public decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
Given a time and some date decrement, computes a new time. Depending on the mapping algorithm from da...
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
Gets the date for different calendar types. Given a time_interval, returns the corresponding date und...
integer function, public days_in_year(Time)
Returns the number of days in the calendar year corresponding to the date represented by time for the...
type(time_type) function scalar_time_mult(n, time)
Returns time multipled by integer factor n.
type(time_type) function, public increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
Increments a time by seconds and days.
logical function leap_year_julian(Time)
Returns the number of days in a julian month.
subroutine, public print_date(Time, str, unit)
Prints the time to standard output (or optional unit) as a date.
subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)
Gets the date on a Gregorian calendar. Computes the year, month, day on the fly from the quantity tim...
type(time_type) function set_time_i(seconds, days, ticks, err_msg)
Returns a time_type set to the given amount of time via integer amounts.
integer function days_in_month_julian(Time)
Returns the number of days in a julian month.
subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)
Base date for Julian calendar is year 1 with all multiples of 4 years being leap years.
subroutine, public time_manager_init()
Initialization routine. Writes the version information to the log file.
logical function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
Sets Time_outdays on a Gregorian calendar Computes the total number of days between 1/1/0001 to the c...
logical function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
Sets days for different calendar types. Given an input date in year, month, days, etc....
integer function days_in_month_thirty(Time)
Returns the number of days in a thirty day month (needed for transparent changes to calendar type).
subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
Computes date corresponding to time interval for 30 day months, 12 month years.
type(time_type) function real4_to_time_type(x, err_msg)
integer function, public days_in_month(Time, err_msg)
Given a time, computes the corresponding date given the selected date time mapping algorithm.
logical function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)
Increments a time by seconds, days and ticks.
logical function set_time_private(seconds, days, ticks, Time_out, err_msg)
Returns a time interval corresponding to this number of days, seconds, and ticks. days,...
integer, parameter days_in_400_year_period
Used only for gregorian.
character(len=9) function, public month_name(n)
Returns a character string containing the name of the month corresponding to month number n.
type(time_type) function real8_to_time_type(x, err_msg)
Convert a real number of seconds into a time_type variable.
integer function safe_rtoi(rval, mode)
Convert a floating point value to an integer value.
real(kind=r8_kind) function, public time_type_to_real(time)
Converts time to seconds and returns it as a real number.
logical function leap_year_no_leap(Time)
Another tough one; no leap year returns false for leap year inquiry.
integer function days_in_month_no_leap(Time)
Returns the number of days in a 365 day year month.
logical function, public repeat_alarm(time, alarm_frequency, alarm_length)
Repeat_alarm supports an alarm that goes off with alarm_frequency and lasts for alarm_length....
logical function, public interval_alarm(time, time_interval, alarm, alarm_interval)
Supports a commonly used type of test on times for models. Given the current time,...
integer function time_divide(time1, time2)
Returns the largest integer, n, for which time1 >= time2 * n.
integer function, public get_calendar_type()
Returns default calendar type for mapping from time to date.
subroutine, public print_time(Time, str, unit)
Prints the given time_type argument as a time (using days, seconds and ticks)
subroutine, public set_calendar_type(type, err_msg)
Sets calendar_type for mapping an interval to a date. For the Gregorian calendar, negative years and ...
logical function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
Given a time and some date increment, computes a new time. Depending on the mapping algorithm from da...
subroutine, public time_list_error(T, Terr)
This routine converts the integer tdays to a string.
Given an input date in year, month, days, etc., creates a time_type that represents this time interva...
Given some number of seconds and days, returns the corresponding time_type.
Type to represent amounts of time. Implemented as seconds and days to allow for larger intervals.
Wrapper for the real to time interface Takes seconds as reals to convert to a time_type representatio...