FV3 Bundle
time_manager.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
10 !*
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 !* for more details.
15 !*
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
20 
21 ! <CONTACT EMAIL="fms@gfdl.noaa.gov">
22 ! fms
23 ! </CONTACT>
24 
25 ! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>
26 
27 ! <OVERVIEW>
28 ! A software package that provides a set of simple interfaces for
29 ! modelers to perform computations related to time and dates.
30 ! </OVERVIEW>
31 
32 ! <DESCRIPTION>
33 ! The changes between the lima revision and this revision are more
34 ! extensive that all those between antwerp and lima.
35 ! A brief description of these changes follows.
36 !
37 ! 1) Added option to set the smallest time increment to something less than one second.
38 ! This is controlled by calling the pubic subroutine set_ticks_per_second.
39 !
40 ! 2) Gregorian calendar fixed.
41 !
42 ! 3) Optional error flag added to calling arguments of public routines.
43 ! This allows the using routine to terminate the program. It is likely that more
44 ! diagnostic information is available from the user than from time_manager alone.
45 ! If the error flag is present then it is the responsibility of the using
46 ! routine to test it and add additional information to the error message.
47 !
48 ! 4) Removed the restriction that time increments be positive in routines that increment or decrement
49 ! time and date. The option to prohibit negative increments can be turned on via optional argument.
50 !
51 ! 5) subroutine set_date_c modified to handle strings that include only hours or only hours and minutes.
52 ! This complies with CF convensions.
53 !
54 ! 6) Made calendar specific routines private.
55 ! They are not used, and should not be used, by any using code.
56 !
57 ! 7) Error messages made more informative.
58 !
59 ! The module defines a type that can be used to represent discrete
60 ! times (accurate to one second) and to map these times into dates
61 ! using a variety of calendars. A time is mapped to a date by
62 ! representing the time with respect to an arbitrary base date (refer
63 ! to <B>NOTES</B> section for the <LINK SRC="#base date">base date</LINK> setting).
64 !
65 ! The time_manager provides a single defined type, time_type, which is
66 ! used to store time and date quantities. A time_type is a positive
67 ! definite quantity that represents an interval of time. It can be
68 ! most easily thought of as representing the number of seconds in some
69 ! time interval. A time interval can be mapped to a date under a given
70 ! calendar definition by using it to represent the time that has passed
71 ! since some base date. A number of interfaces are provided to operate
72 ! on time_type variables and their associated calendars. Time intervals
73 ! can be as large as n days where n is the largest number represented by
74 ! the default integer type on a compiler. This is typically considerably
75 ! greater than 10 million years (assuming 32 bit integer representation)
76 ! which is likely to be adequate for most applications. The description
77 ! of the interfaces is separated into two sections. The first deals with
78 ! operations on time intervals while the second deals with operations
79 ! that convert time intervals to dates for a given calendar.
80 
81 ! The smallest increment of time is referred to as a tick.
82 ! A tick cannot be larger than 1 second, which also is the default.
83 ! The number of ticks per second is set via pubic subroutine set_ticks_per_second.
84 ! For example, ticks_per_second = 1000 will set the tick to one millisecond.
85 ! </DESCRIPTION>
86 
87 ! <DATA NAME="time_type" TYPE="derived type">
88 ! Derived-type data variable used to store time and date quantities. It
89 ! contains three PRIVATE variables: days, seconds and ticks.
90 ! </DATA>
91 
92 #include <fms_platform.h>
93 
94 use constants_mod, only: rseconds_per_day=>seconds_per_day
95 use fms_mod, only: error_mesg, fatal, warning, write_version_number, stdout
96 
97 implicit none
98 private
99 
100 ! Module defines a single type
101 public time_type
102 
103 ! Operators defined on time_type
104 public operator(+), operator(-), operator(*), operator(/), &
105  operator(>), operator(>=), operator(==), operator(/=), &
106  operator(<), operator(<=), operator(//), assignment(=)
107 
108 ! Subroutines and functions operating on time_type
111 public time_list_error
112 
113 ! List of available calendar types
115 
116 ! Subroutines and functions involving relations between time and calendar
117 public set_calendar_type
118 public get_calendar_type
121 public set_date
122 public get_date
123 public increment_date
124 public decrement_date
125 public days_in_month
126 public leap_year
127 public length_of_year
128 public days_in_year
129 public day_of_year
130 public month_name
131 
133 
134 ! Subroutines for printing version number and time type
136 
137 ! The following exist only for interpolator.F90
138 ! interpolator.F90 uses them to do a calendar conversion,
139 ! which is also done by get_cal_time. interpolator.F90
140 ! should be modified to use get_cal_time instead.
141 ! After interpolator.F90 is fixed, these can be removed
142 ! and the corresponding private routines can be renamed.
143 ! (e.g., rename set_date_julian_private to be just set_date_julian)
145 
146 public :: date_to_string
147 
148 !====================================================================
149 
150 ! Global data to define calendar type
151 integer, parameter :: thirty_day_months = 1, julian = 2, &
152  gregorian = 3, noleap = 4, &
154 integer, private :: calendar_type = no_calendar
155 integer, parameter :: max_type = 4
156 
157 ! Define number of days per month
158 integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
159 integer, parameter :: seconds_per_day = rseconds_per_day ! This should automatically cast real to integer
160 integer, parameter :: days_in_400_year_period = 146097 ! Used only for gregorian
161 integer, dimension(days_in_400_year_period) :: coded_date ! Used only for gregorian
162 integer, dimension(400,12,31) :: date_to_day ! Used only for gregorian
163 integer, parameter :: invalid_date=-1 ! Used only for gregorian
164 
165 ! time_type is implemented as seconds and days to allow for larger intervals
167  private
168  integer:: seconds
169  integer:: days
170  integer:: ticks
171  integer:: dummy ! added as a workaround bug on IRIX64 (AP)
172 end type time_type
173 
174 !======================================================================
175 
176 interface operator (+); module procedure time_plus; end interface
177 interface operator (-); module procedure time_minus; end interface
178 interface operator (*); module procedure time_scalar_mult
179  module procedure scalar_time_mult; end interface
180 interface operator (/); module procedure time_scalar_divide
181  module procedure time_divide; end interface
182 interface operator (>); module procedure time_gt; end interface
183 interface operator (>=); module procedure time_ge; end interface
184 interface operator (<); module procedure time_lt; end interface
185 interface operator (<=); module procedure time_le; end interface
186 interface operator (==); module procedure time_eq; end interface
187 interface operator (/=); module procedure time_ne; end interface
188 interface operator (//); module procedure time_real_divide; end interface
189 interface assignment(=); module procedure time_assignment; end interface
190 
191 !======================================================================
192 
193 interface set_time
194  module procedure set_time_i, set_time_c
195 end interface
196 
197 interface set_date
198  module procedure set_date_i, set_date_c
199 end interface
200 
201 !======================================================================
202 
203 ! Include variable "version" to be written to log file.
204 #include<file_version.h>
205 logical :: module_is_initialized = .false.
206 
207 !======================================================================
208 
209 ! A tick is the smallest increment of time.
210 ! That is, smallest increment of time = (1/ticks_per_second) seconds
211 
212 integer :: ticks_per_second = 1
213 
214 !======================================================================
215 contains
216 
217 ! First define all operations on time intervals independent of calendar
218 
219 !=========================================================================
220 ! <FUNCTION NAME="set_time">
221 
222 ! <OVERVIEW>
223 ! Given some number of seconds and days, returns the
224 ! corresponding time_type.
225 ! </OVERVIEW>
226 ! <DESCRIPTION>
227 ! Given some number of seconds and days, returns the
228 ! corresponding time_type. set_time has two forms;
229 ! one accepts integer input, the other a character string.
230 ! For the first form, there are no restrictions on the range of the inputs,
231 ! except that the result must be positive time.
232 ! e.g. days=-1, seconds=86401 is acceptable.
233 ! For the second form, days and seconds must both be positive.
234 ! </DESCRIPTION>
235 ! <TEMPLATE>
236 ! 1. set_time(seconds, days, ticks, err_msg)
237 ! </TEMPLATE>
238 ! <TEMPLATE>
239 ! 2. set_time(time_string, err_msg, allow_rounding)
240 ! </TEMPLATE>
241 
242 ! <IN NAME="seconds" UNITS="" TYPE="integer" DIM="(scalar)">
243 ! A number of seconds.
244 ! </IN>
245 ! <IN NAME="days" UNITS="" TYPE="integer" DIM="(scalar)">
246 ! A number of days.
247 ! </IN>
248 ! <IN NAME="ticks" UNITS="" TYPE="integer, optional" DIM="(scalar)">
249 ! A number of ticks.
250 ! </IN>
251 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
252 ! When present, and when non-blank, a fatal error condition as been detected.
253 ! The string itself is an error message.
254 ! It is recommended that, when err_msg is present in the call
255 ! to this routine, the next line of code should be something
256 ! similar to this:
257 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
258 ! </OUT>
259 ! <IN NAME="time_string" TYPE="character">
260 ! Contains days and seconds separated by a single blank.
261 ! days must be integer, seconds may be integer or real.
262 ! Examples: '100 43200' '100 43200.50'
263 ! </IN>
264 ! <IN NAME="allow_rounding" TYPE="logical, optional" DEFAULT=".true.">
265 ! When .true., any fractions of a second will be rounded off to the nearest tick.
266 ! When .false., it is a fatal error if the second fraction cannot be exactly
267 ! represented by a number of ticks.
268 ! </IN>
269 ! <OUT NAME="set_time" UNITS="" TYPE="" DIM="" DEFAULT="">
270 ! A time interval corresponding to this number of days and seconds.
271 ! </OUT>
272 
273  function set_time_private(seconds, days, ticks, Time_out, err_msg)
275 ! Returns a time interval corresponding to this number of days, seconds, and ticks.
276 ! days, seconds and ticks may be negative, but resulting time must be positive.
277 
278 ! -- pjp --
279 ! To understand why inputs may be negative,
280 ! one needs to understand the intrinsic function "modulo".
281 ! The expanation below is copied from a web page on fortran 90
282 
283 ! In addition, CEILING, FLOOR and MODULO have been added to Fortran 90.
284 ! Only the last one is difficult to explain, which is most easily done with the examples from ISO (1991)
285 
286 ! MOD (8,5) gives 3 MODULO (8,5) gives 3
287 ! MOD (-8,5) gives -3 MODULO (-8,5) gives 2
288 ! MOD (8,-5) gives 3 MODULO (8,-5) gives -2
289 ! MOD (-8,-5) gives -3 MODULO (-8,-5) gives -3
290 
291 ! I don't think it is difficult to explain.
292 ! I think that is it sufficient to say this:
293 ! "The result of modulo(n,m) has the sign of m"
294 ! -- pjp --
295 
296  logical :: set_time_private
297  integer, intent(in) :: seconds, days, ticks
298  type(time_type), intent(out) :: time_out
299  character(len=*), intent(out) :: err_msg
300  integer :: seconds_new, days_new, ticks_new
301 
302  seconds_new = seconds + floor(ticks/real(ticks_per_second))
303  ticks_new = modulo(ticks,ticks_per_second)
304  days_new = days + floor(seconds_new/real(seconds_per_day))
305  seconds_new = modulo(seconds_new,seconds_per_day)
306 
307  if ( seconds_new < 0 .or. ticks_new < 0) then
308  call error_mesg('function set_time_i','Bad result for time. Contact those responsible for maintaining time_manager',fatal)
309  endif
310 
311  if(days_new < 0) then
312  write(err_msg,'(a,i6,a,i6,a,i6)') 'time is negative. days=',days_new,' seconds=',seconds_new,' ticks=',ticks_new
313  set_time_private = .false.
314  else
315  time_out%days = days_new
316  time_out%seconds = seconds_new
317  time_out%ticks = ticks_new
318  err_msg = ''
319  set_time_private = .true.
320  endif
321 
322  end function set_time_private
323 !---------------------------------------------------------------------------
324 
325  function set_time_i(seconds, days, ticks, err_msg)
327  integer, intent(in) :: seconds
328  integer, intent(in), optional :: days, ticks
329  character(len=*), intent(out), optional :: err_msg
330  character(len=128) :: err_msg_local
331  integer :: odays, oticks
332 
334 
335  odays = 0; if(present(days)) odays = days
336  oticks = 0; if(present(ticks)) oticks = ticks
337  if(present(err_msg)) err_msg = ''
338 
339  if(.not.set_time_private(seconds, odays, oticks, set_time_i, err_msg_local)) then
340  if(error_handler('function set_time_i', trim(err_msg_local), err_msg)) return
341  endif
342 
343  end function set_time_i
344 !---------------------------------------------------------------------------
345 
346  function set_time_c(string, err_msg, allow_rounding)
348  type(time_type) :: set_time_c
349  character(len=*), intent(in) :: string
350  character(len=*), intent(out), optional :: err_msg
351  logical, intent(in), optional :: allow_rounding
352 
353  character(len=4) :: formt='(i )'
354  integer :: i1, i2, i3, day, second, tick, nsps
355  character(len=32) :: string_sifted_left
356  character(len=128) :: err_msg_local
357  logical :: allow_rounding_local
358 
360  if(present(err_msg)) err_msg = ''
361  allow_rounding_local=.true.; if(present(allow_rounding)) allow_rounding_local=allow_rounding
362 
363  err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)
364 
365  string_sifted_left = adjustl(string)
366  i1 = index(trim(string_sifted_left),' ')
367  if(i1 == 0) then
368  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
369  endif
370  if(index(string,'-') /= 0 .or. index(string,':') /= 0) then
371  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
372  endif
373 
374  i2 = index(trim(string_sifted_left),'.')
375  i3 = len_trim(cut0(string_sifted_left))
376 
377  if(i2 /= 0) then ! There is no decimal point
378  ! Check that decimal is on seconds (not days)
379  if(i2 < i1) then
380  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
381  endif
382  endif
383  write(formt(3:3),'(i1)') i1-1
384  read(string_sifted_left(1:i1-1),formt) day
385 
386  if(i2 == 0) then ! There is no decimal point
387  write(formt(3:3),'(i1)') i3-i1
388  read(string_sifted_left(i1+1:i3),formt) second
389  tick = 0
390  else ! There is a decimal point
391  ! nsps = spaces occupied by whole number of seconds
392  nsps = i2-i1-1
393  if(nsps == 0) then
394  second = 0
395  else
396  write(formt(3:3),'(i1)') nsps
397  read(string_sifted_left(i1+1:i2-1),formt) second
398  endif
399 
400  if(.not.get_tick_from_string(string_sifted_left(i2:i3), err_msg_local, allow_rounding_local, tick)) then
401  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
402  endif
403  ! If tick has been rounded up to ticks_per_second, then bump up second.
404  if(tick == ticks_per_second) then
405  second = second + 1
406  tick = 0
407  endif
408  endif
409 
410  if(.not.set_time_private(second, day, tick, set_time_c, err_msg_local)) then
411  if(error_handler('function set_time_c', err_msg_local, err_msg)) return
412  endif
413 
414  end function set_time_c
415 !---------------------------------------------------------------------------
416 ! </FUNCTION>
417 
418  function get_tick_from_string(string, err_msg, allow_rounding, tick)
420  logical :: get_tick_from_string
421  character(len=*), intent(in) :: string
422  character(len=*), intent(out) :: err_msg
423  logical, intent(in) :: allow_rounding
424  integer, intent(out) :: tick
425 
426  character(len=4) :: formt='(i )'
427  integer :: i3, nspf, fraction, magnitude, tpsfrac
428 
429  err_msg = ''
430  get_tick_from_string = .true.
431  i3 = len_trim(string)
432  nspf = i3 - 1 ! nspf = spaces occupied by fractional seconds, excluding decimal point
433  if(nspf == 0) then
434  tick = 0 ! Nothing to the right of the decimal point
435  else
436  write(formt(3:3),'(i1)') nspf
437  read(string(2:i3),formt) fraction
438  if(fraction == 0) then
439  tick = 0 ! All zeros to the right of the decimal point
440  else
441  magnitude = 10**nspf
442  tpsfrac = ticks_per_second*fraction
443  if(allow_rounding) then
444  tick = nint((real(tpsfrac)/magnitude))
445  else
446  if(modulo(tpsfrac,magnitude) == 0) then
447  tick = tpsfrac/magnitude
448  else
449  write(err_msg,'(a,i6)') 'Second fraction cannot be exactly represented with ticks. '// &
450  'fraction='//trim(string)//' ticks_per_second=',ticks_per_second
451  get_tick_from_string = .false.
452  endif
453  endif
454  endif
455  endif
456 
457  end function get_tick_from_string
458 !---------------------------------------------------------------------------
459 ! <SUBROUTINE NAME="get_time">
460 
461 ! <OVERVIEW>
462 ! Given a time interval, returns the corresponding seconds and days.
463 ! </OVERVIEW>
464 ! <DESCRIPTION>
465 ! Given a time interval, returns the corresponding seconds and days.
466 ! </DESCRIPTION>
467 ! <TEMPLATE>
468 ! get_time(time, seconds, days, ticks, err_msg)
469 ! </TEMPLATE>
470 
471 ! <IN NAME="time" TYPE="time_type">
472 ! A time interval.
473 ! </IN>
474 ! <OUT NAME="seconds" UNITS="" TYPE="integer" DIM="(scalar)">
475 ! A number of seconds.
476 ! </OUT>
477 ! <OUT NAME="days" UNITS="" TYPE="integer" DIM="(scalar)">
478 ! A number of days.
479 ! </OUT>
480 ! <OUT NAME="ticks" UNITS="" TYPE="integer, optional" DIM="(scalar)">
481 ! A number of ticks.
482 ! </OUT>
483 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
484 ! When present, and when non-blank, a fatal error condition as been detected.
485 ! The string itself is an error message.
486 ! It is recommended that, when err_msg is present in the call
487 ! to this routine, the next line of code should be something
488 ! similar to this:
489 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
490 ! </OUT>
491 
492 subroutine get_time(Time, seconds, days, ticks, err_msg)
494 ! Returns days and seconds ( < 86400 ) corresponding to a time.
495 
496 type(time_type), intent(in) :: time
497 integer, intent(out) :: seconds
498 integer, intent(out), optional :: days, ticks
499 character(len=*), intent(out), optional :: err_msg
500 character(len=128) :: err_msg_local
501 
503 if(present(err_msg)) err_msg = ''
504 
505 seconds = time%seconds
506 
507 if(present(ticks)) then
508  ticks = time%ticks
509 else
510  if(time%ticks /= 0) then
511  err_msg_local = 'subroutine get_time: ticks must be present when time has a second fraction'
512  if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
513  endif
514 endif
515 
516 if (present(days)) then
517  days = time%days
518 else
519  if (time%days > (huge(seconds) - seconds)/seconds_per_day) then
520  err_msg_local = 'Integer overflow in seconds. Optional argument days must be present.'
521  if(error_handler('subroutine get_time', err_msg_local, err_msg)) return
522  endif
523  seconds = seconds + time%days * seconds_per_day
524 endif
525 
526 end subroutine get_time
527 ! </SUBROUTINE>
528 
529 !-------------------------------------------------------------------------
530 ! <FUNCTION NAME="increment_time">
531 
532 ! <OVERVIEW>
533 ! Given a time and an increment of days and seconds, returns
534 ! a time that adds this increment to an input time.
535 ! </OVERVIEW>
536 ! <DESCRIPTION>
537 ! Given a time and an increment of days and seconds, returns
538 ! a time that adds this increment to an input time.
539 ! Increments a time by seconds and days.
540 ! </DESCRIPTION>
541 ! <TEMPLATE>
542 ! increment_time(time, seconds, days, ticks, err_msg, allow_neg_inc)
543 ! </TEMPLATE>
544 
545 ! <IN NAME="time" TYPE="time_type" DIM="(scalar)">
546 ! A time interval.
547 ! </IN>
548 ! <IN NAME="seconds" TYPE="integer" DIM="(scalar)">
549 ! Increment of seconds.
550 ! </IN>
551 ! <IN NAME="days" UNITS="" TYPE="integer, optional" DIM="(scalar)">
552 ! Increment of days.
553 ! </IN>
554 ! <IN NAME="ticks" TYPE="integer, optional" DIM="(scalar)">
555 ! Increment of ticks.
556 ! </IN>
557 ! <OUT NAME="increment_time" TYPE="time_type" DIM="(scalar)">
558 ! A time that adds this increment to the input time.
559 ! A negative result is a fatal error.
560 ! </OUT>
561 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
562 ! When present, and when non-blank, a fatal error condition as been detected.
563 ! The string itself is an error message.
564 ! It is recommended that, when err_msg is present in the call
565 ! to this routine, the next line of code should be something
566 ! similar to this:
567 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
568 ! </OUT>
569 ! <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
570 ! When .false., it is a fatal error if any of the input time increments are negative.
571 ! This mimics the behavior of lima and earlier revisions.
572 ! </IN>
573 
574  function increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
576 ! Increments a time by seconds, days and ticks.
577 
578  type(time_type) :: increment_time
579  type(time_type), intent(in) :: time
580  integer, intent(in) :: seconds
581  integer, intent(in), optional :: days, ticks
582  character(len=*), intent(out), optional :: err_msg
583  logical, intent(in), optional :: allow_neg_inc
584 
585  integer :: odays, oticks
586  character(len=128) :: err_msg_local
587  logical :: allow_neg_inc_local
588 
589  odays = 0; if(present(days)) odays = days
590  oticks = 0; if(present(ticks)) oticks = ticks
591  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
592 
593  if(.not.allow_neg_inc_local) then
594  if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
595  write(err_msg_local,10) seconds, odays, oticks
596  10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6)
597  if(error_handler('function increment_time', err_msg_local, err_msg)) return
598  endif
599  endif
600 
601  if(.not.increment_time_private(time, seconds, odays, oticks, increment_time, err_msg_local)) then
602  if(error_handler('function increment_time', err_msg_local, err_msg)) return
603  endif
604 
605  end function increment_time
606 ! </FUNCTION>
607 !--------------------------------------------------------------------------
608 
609  function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)
611 ! Increments a time by seconds, days and ticks.
612 
613  logical :: increment_time_private
614  type(time_type), intent(in) :: time_in
615  integer, intent(in) :: seconds, days, ticks
616  type(time_type), intent(out) :: time_out
617  character(len=*), intent(out) :: err_msg
618 
619 ! Watch for immediate overflow on days or seconds
620  if(days >= huge(days) - time_in%days) then
621  err_msg = 'Integer overflow in days in increment_time'
622  increment_time_private = .false.
623  return
624  endif
625  if(seconds >= huge(seconds) - time_in%seconds) then
626  err_msg = 'Integer overflow in seconds in increment_time'
627  increment_time_private = .false.
628  return
629  endif
630 
631  increment_time_private = set_time_private(time_in%seconds+seconds, time_in%days+days, time_in%ticks+ticks, time_out, err_msg)
632 
633  end function increment_time_private
634 
635 !--------------------------------------------------------------------------
636 ! <FUNCTION NAME="decrement_time">
637 
638 ! <OVERVIEW>
639 ! Given a time and a decrement of days and seconds, returns
640 ! a time that subtracts this decrement from an input time.
641 ! </OVERVIEW>
642 ! <DESCRIPTION>
643 ! Decrements a time by seconds and days.
644 ! </DESCRIPTION>
645 ! <TEMPLATE>
646 ! Decrement_time(time, seconds, days, ticks, err_msg, allow_neg_inc)
647 ! </TEMPLATE>
648 
649 ! <IN NAME="time" TYPE="time_type" DIM="(scalar)">
650 ! A time interval.
651 ! </IN>
652 ! <IN NAME="seconds" TYPE="integer" DIM="(scalar)">
653 ! Decrement of seconds.
654 ! </IN>
655 ! <IN NAME="days" TYPE="integer, optional" DIM="(scalar)">
656 ! Decrement of days.
657 ! </IN>
658 ! <IN NAME="ticks" TYPE="integer, optional" DIM="(scalar)">
659 ! Decrement of ticks.
660 ! </IN>
661 ! <OUT NAME="decrement_time" TYPE="time_type">
662 ! A time that subtracts this decrement from an input time.
663 ! A negative result is a fatal error.
664 ! </OUT>
665 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
666 ! When present, and when non-blank, a fatal error condition as been detected.
667 ! The string itself is an error message.
668 ! It is recommended that, when err_msg is present in the call
669 ! to this routine, the next line of code should be something
670 ! similar to this:
671 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
672 ! </OUT>
673 ! <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
674 ! When .false., it is a fatal error if any of the input time increments are negative.
675 ! This mimics the behavior of lima and earlier revisions.
676 ! </IN>
677 
678 function decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
680 ! Decrements a time by seconds, days and ticks.
681 
682 type(time_type) :: decrement_time
683 type(time_type), intent(in) :: time
684 integer, intent(in) :: seconds
685 integer, intent(in), optional :: days, ticks
686 character(len=*), intent(out), optional :: err_msg
687 logical, intent(in), optional :: allow_neg_inc
688 
689 integer :: odays, oticks
690 character(len=128) :: err_msg_local
691 logical :: allow_neg_inc_local
692 
693 odays = 0; if (present(days)) odays = days
694 oticks = 0; if (present(ticks)) oticks = ticks
695 allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
696 
697 if(.not.allow_neg_inc_local) then
698  if(seconds < 0 .or. odays < 0 .or. oticks < 0) then
699  write(err_msg_local,10) seconds,odays,oticks
700  10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6)
701  if(error_handler('function decrement_time', err_msg_local, err_msg)) return
702  endif
703 endif
704 
705  if(.not.increment_time_private(time, -seconds, -odays, -oticks, decrement_time, err_msg_local)) then
706  if(error_handler('function decrement_time', err_msg_local, err_msg)) return
707  endif
708 
709 end function decrement_time
710 ! </FUNCTION>
711 
712 !--------------------------------------------------------------------------
713 ! <FUNCTION NAME="time_gt operator(>)">
714 
715 ! <OVERVIEW>
716 ! Returns true if time1 > time2.
717 ! </OVERVIEW>
718 ! <DESCRIPTION>
719 ! Returns true if time1 > time2.
720 ! </DESCRIPTION>
721 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
722 ! A time interval.
723 ! </IN>
724 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
725 ! A time interval.
726 ! </IN>
727 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
728 ! Returns true if time1 > time2
729 ! </OUT>
730 ! <TEMPLATE>
731 ! time_gt(time1, time2)
732 ! </TEMPLATE>
733 
734 function time_gt(time1, time2)
736 ! Returns true if time1 > time2
737 
738 logical :: time_gt
739 type(time_type), intent(in) :: time1, time2
740 
741 time_gt = (time1%days > time2%days)
742 if(time1%days == time2%days) then
743  if(time1%seconds == time2%seconds) then
744  time_gt = (time1%ticks > time2%ticks)
745  else
746  time_gt = (time1%seconds > time2%seconds)
747  endif
748 endif
749 
750 end function time_gt
751 ! </FUNCTION>
752 
753 !--------------------------------------------------------------------------
754 ! <FUNCTION NAME="time_ge; operator(>=)">
755 
756 ! <OVERVIEW>
757 ! Returns true if time1 >= time2.
758 ! </OVERVIEW>
759 ! <DESCRIPTION>
760 ! Returns true if time1 >= time2.
761 ! </DESCRIPTION>
762 ! <TEMPLATE>
763 ! time_ge(time1, time2)
764 ! </TEMPLATE>
765 
766 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
767 ! A time interval.
768 ! </IN>
769 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
770 ! A time interval.
771 ! </IN>
772 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
773 ! Returns true if time1 >= time2
774 ! </OUT>
775 
776 function time_ge(time1, time2)
778 ! Returns true if time1 >= time2
779 
780 logical :: time_ge
781 type(time_type), intent(in) :: time1, time2
782 
783 time_ge = (time_gt(time1, time2) .or. time_eq(time1, time2))
784 
785 end function time_ge
786 ! </FUNCTION>
787 
788 !--------------------------------------------------------------------------
789 ! <FUNCTION NAME="time_lt; operator(<)">
790 
791 ! <OVERVIEW>
792 ! Returns true if time1 < time2.
793 ! </OVERVIEW>
794 ! <DESCRIPTION>
795 ! Returns true if time1 < time2.
796 ! </DESCRIPTION>
797 ! <TEMPLATE>
798 ! time_lt(time1, time2)
799 ! </TEMPLATE>
800 
801 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
802 ! A time interval.
803 ! </IN>
804 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
805 ! A time interval.
806 ! </IN>
807 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
808 ! Returns true if time1 < time2
809 ! </OUT>
810 
811 function time_lt(time1, time2)
813 ! Returns true if time1 < time2
814 
815 logical :: time_lt
816 type(time_type), intent(in) :: time1, time2
817 
818 time_lt = (time1%days < time2%days)
819 if(time1%days == time2%days)then
820  if(time1%seconds == time2%seconds) then
821  time_lt = (time1%ticks < time2%ticks)
822  else
823  time_lt = (time1%seconds < time2%seconds)
824  endif
825 endif
826 end function time_lt
827 ! </FUNCTION>
828 
829 !--------------------------------------------------------------------------
830 ! <FUNCTION NAME="time_le; operator(<=)">
831 
832 ! <OVERVIEW>
833 ! Returns true if time1 <= time2.
834 ! </OVERVIEW>
835 ! <DESCRIPTION>
836 ! Returns true if time1 <= time2.
837 ! </DESCRIPTION>
838 ! <TEMPLATE>
839 ! time_le(time1, time2)
840 ! </TEMPLATE>
841 
842 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
843 ! A time interval.
844 ! </IN>
845 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
846 ! A time interval.
847 ! </IN>
848 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
849 ! Returns true if time1 <= time2
850 ! </OUT>
851 
852 function time_le(time1, time2)
854 ! Returns true if time1 <= time2
855 
856 logical :: time_le
857 type(time_type), intent(in) :: time1, time2
858 
859 time_le = (time_lt(time1, time2) .or. time_eq(time1, time2))
860 
861 end function time_le
862 ! </FUNCTION>
863 
864 !--------------------------------------------------------------------------
865 ! <FUNCTION NAME="time_eq; operator(==)">
866 
867 ! <OVERVIEW>
868 ! Returns true if time1 == time2.
869 ! </OVERVIEW>
870 ! <DESCRIPTION>
871 ! Returns true if time1 == time2.
872 ! </DESCRIPTION>
873 ! <TEMPLATE>
874 ! time_eq(time1, time2)
875 ! </TEMPLATE>
876 
877 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
878 ! A time interval.
879 ! </IN>
880 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
881 ! A time interval.
882 ! </IN>
883 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
884 ! Returns true if time1 == time2
885 ! </OUT>
886 
887 function time_eq(time1, time2)
889 ! Returns true if time1 == time2
890 
891 logical :: time_eq
892 type(time_type), intent(in) :: time1, time2
893 
895 
896 time_eq = (time1%seconds == time2%seconds .and. time1%days == time2%days &
897  .and. time1%ticks == time2%ticks)
898 
899 end function time_eq
900 ! </FUNCTION>
901 
902 !--------------------------------------------------------------------------
903 ! <FUNCTION NAME="time_ne; operator(/=)">
904 
905 ! <OVERVIEW>
906 ! Returns true if time1 /= time2.
907 ! </OVERVIEW>
908 ! <DESCRIPTION>
909 ! Returns true if time1 /= time2.
910 ! </DESCRIPTION>
911 ! <TEMPLATE>
912 ! time_ne(time1, time2)
913 ! </TEMPLATE>
914 
915 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
916 ! A time interval.
917 ! </IN>
918 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
919 ! A time interval.
920 ! </IN>
921 ! <OUT NAME="" UNITS="" TYPE="logical" DIM="" DEFAULT="">
922 ! Returns true if time1 /= time2
923 ! </OUT>
924 
925 function time_ne(time1, time2)
927 ! Returns true if time1 /= time2
928 
929 logical :: time_ne
930 type(time_type), intent(in) :: time1, time2
931 
932 time_ne = (.not. time_eq(time1, time2))
933 
934 end function time_ne
935 ! </FUNCTION>
936 
937 !-------------------------------------------------------------------------
938 ! <FUNCTION NAME="time_plus; operator(+)">
939 
940 ! <OVERVIEW>
941 ! Returns sum of two time_types.
942 ! </OVERVIEW>
943 ! <TEMPLATE>
944 ! time1 + time2
945 ! </TEMPLATE>
946 ! <DESCRIPTION>
947 ! Returns sum of two time_types.
948 ! </DESCRIPTION>
949 
950 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
951 ! A time interval.
952 ! </IN>
953 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
954 ! A time interval.
955 ! </IN>
956 ! <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
957 ! Returns sum of two time_types.
958 ! </OUT>
959 
960 function time_plus(time1, time2)
962 ! Returns sum of two time_types
963 
964 type(time_type) :: time_plus
965 type(time_type), intent(in) :: time1, time2
966 
968 
969 time_plus = increment_time(time1, time2%seconds, time2%days, time2%ticks)
970 
971 end function time_plus
972 ! </FUNCTION>
973 
974 !-------------------------------------------------------------------------
975 ! <FUNCTION NAME="time_minus; operator(-)">
976 
977 ! <OVERVIEW>
978 ! Returns difference of two time_types.
979 ! </OVERVIEW>
980 ! <DESCRIPTION>
981 ! Returns difference of two time_types. WARNING: a time type is positive
982 ! so by definition time1 - time2 is the same as time2 - time1.
983 ! </DESCRIPTION>
984 ! <TEMPLATE>
985 ! time_minus(time1, time2)
986 ! </TEMPLATE>
987 ! <TEMPLATE>
988 ! time1 - time2
989 ! </TEMPLATE>
990 
991 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
992 ! A time interval.
993 ! </IN>
994 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
995 ! A time interval.
996 ! </IN>
997 ! <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
998 ! Returns difference of two time_types.
999 ! </OUT>
1000 
1001 function time_minus(time1, time2)
1003 ! Returns difference of two time_types. WARNING: a time type is positive
1004 ! so by definition time1 - time2 is the same as time2 - time1.
1005 
1006 type(time_type) :: time_minus
1007 type(time_type), intent(in) :: time1, time2
1008 
1010 
1011 if(time1 > time2) then
1012  time_minus = decrement_time(time1, time2%seconds, time2%days, time2%ticks)
1013 else
1014  time_minus = decrement_time(time2, time1%seconds, time1%days, time1%ticks)
1015 endif
1016 
1017 end function time_minus
1018 ! </FUNCTION>
1019 
1020 !--------------------------------------------------------------------------
1021 ! <FUNCTION NAME="time_scalar_mult; operator(*)">
1022 
1023 ! <OVERVIEW>
1024 ! Returns time multiplied by integer factor n.
1025 ! </OVERVIEW>
1026 ! <DESCRIPTION>
1027 ! Returns time multiplied by integer factor n.
1028 ! </DESCRIPTION>
1029 ! <TEMPLATE>
1030 ! time_scalar_mult(time, n)
1031 ! </TEMPLATE>
1032 
1033 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
1034 ! A time interval.
1035 ! </IN>
1036 ! <IN NAME="n" UNITS="" TYPE="integer" DIM="">
1037 ! A time interval.
1038 ! </IN>
1039 ! <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
1040 ! Returns time multiplied by integer factor n.
1041 ! </OUT>
1042 
1043 function time_scalar_mult(time, n)
1045 ! Returns time multiplied by integer factor n
1046 
1047 type(time_type) :: time_scalar_mult
1048 type(time_type), intent(in) :: time
1049 integer, intent(in) :: n
1050 integer :: days, seconds, ticks, num_sec
1051 double precision :: sec_prod, tick_prod
1052 
1054 
1055 ! Multiplying here in a reasonable fashion to avoid overflow is tricky
1056 ! Could multiply by some large factor n, and seconds could be up to 86399
1057 ! Need to avoid overflowing integers and wrapping around to negatives
1058 ! ticks could be up to ticks_per_second-1
1059 
1060 tick_prod = dble(time%ticks) * dble(n)
1061 num_sec = tick_prod/dble(ticks_per_second)
1062 sec_prod = dble(time%seconds) * dble(n) + num_sec
1063 ticks = tick_prod - num_sec * ticks_per_second
1064 
1065 ! If sec_prod is large compared to precision of double precision, things
1066 ! can go bad. Need to warn and abort on this.
1067 ! The same is true of tick_prod but is is more likely to happen to sec_prod,
1068 ! so let's just test sec_prod. (A test of tick_prod would be necessary only
1069 ! if ticks_per_second were greater than seconds_per_day)
1070 if(sec_prod /= 0.0) then
1071  if(log10(sec_prod) > precision(sec_prod) - 3) call error_mesg('time_scalar_mult', &
1072  'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',fatal)
1073 end if
1074 
1075 days = sec_prod / dble(seconds_per_day)
1076 seconds = sec_prod - dble(days) * dble(seconds_per_day)
1077 
1078 time_scalar_mult = set_time(seconds, time%days * n + days, ticks)
1079 
1080 end function time_scalar_mult
1081 ! </FUNCTION>
1082 
1083 !-------------------------------------------------------------------------
1084 ! <FUNCTION NAME="scalar_time_mult; operator(*)">
1085 
1086 ! <OVERVIEW>
1087 ! Returns time multiplied by integer factor n.
1088 ! </OVERVIEW>
1089 ! <DESCRIPTION>
1090 ! Returns time multiplied by integer factor n.
1091 ! </DESCRIPTION>
1092 ! <TEMPLATE>
1093 ! n * time
1094 ! scalar_time_mult(n, time)
1095 ! </TEMPLATE>
1096 
1097 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
1098 ! <IN NAME="n" UNITS="" TYPE="integer" DIM=""> An integer. </IN>
1099 ! <OUT NAME="" UNITS="" TYPE="time_type" DIM="" DEFAULT="">
1100 ! Returns time multiplied by integer factor n.
1101 ! </OUT>
1102 
1103 function scalar_time_mult(n, time)
1105 ! Returns time multipled by integer factor n
1106 
1107 type(time_type) :: scalar_time_mult
1108 type(time_type), intent(in) :: time
1109 integer, intent(in) :: n
1110 
1111 scalar_time_mult = time_scalar_mult(time, n)
1112 
1113 end function scalar_time_mult
1114 ! </FUNCTION>
1115 
1116 !-------------------------------------------------------------------------
1117 ! <FUNCTION NAME="time_divide; operator(/)">
1118 
1119 ! <OVERVIEW>
1120 ! Returns the largest integer, n, for which time1 >= time2 * n.
1121 ! </OVERVIEW>
1122 ! <DESCRIPTION>
1123 ! Returns the largest integer, n, for which time1 >= time2 * n.
1124 ! </DESCRIPTION>
1125 ! <TEMPLATE>
1126 ! n = time1 / time2
1127 ! time_divide(time1, time2)
1128 ! </TEMPLATE>
1129 
1130 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
1131 ! A time interval.
1132 ! </IN>
1133 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
1134 ! A time interval.
1135 ! </IN>
1136 ! <OUT NAME="" UNITS="" TYPE="integer" DIM="" DEFAULT="">
1137 ! Returns the largest integer, n, for which time1 >= time2 * n.
1138 ! </OUT>
1139 
1140 function time_divide(time1, time2)
1142 ! Returns the largest integer, n, for which time1 >= time2 * n.
1143 
1144 integer :: time_divide
1145 type(time_type), intent(in) :: time1, time2
1146 double precision :: d1, d2
1147 
1149 
1150 ! Convert time intervals to floating point days; risky for general performance?
1151 d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + time1%ticks/dble(ticks_per_second)
1152 d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + time2%ticks/dble(ticks_per_second)
1153 
1154 ! Get integer quotient of this, check carefully to avoid round-off problems.
1155 time_divide = d1 / d2
1156 
1157 ! Verify time_divide*time2 is <= time1 and (time_divide + 1)*time2 is > time1
1158 if(time_divide * time2 > time1 .or. (time_divide + 1) * time2 <= time1) &
1159  call error_mesg('time_divide',' quotient error :: notify developer',fatal)
1160 
1161 end function time_divide
1162 ! </FUNCTION>
1163 
1164 !-------------------------------------------------------------------------
1165 ! <FUNCTION NAME="time_real_divide; operator(//)">
1166 
1167 ! <OVERVIEW>
1168 ! Returns the double precision quotient of two times.
1169 ! </OVERVIEW>
1170 ! <DESCRIPTION>
1171 ! Returns the double precision quotient of two times.
1172 ! </DESCRIPTION>
1173 ! <TEMPLATE>
1174 ! time1 // time2
1175 ! time_real_divide(time1, time2)
1176 ! </TEMPLATE>
1177 
1178 ! <IN NAME="time1" UNITS="" TYPE="time_type" DIM="">
1179 ! A time interval.
1180 ! </IN>
1181 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
1182 ! A time interval.
1183 ! </IN>
1184 ! <OUT NAME="" UNITS="" TYPE="integer" DIM="double precision" DEFAULT="">
1185 ! Returns the double precision quotient of two times
1186 ! </OUT>
1187 
1188 function time_real_divide(time1, time2)
1190 ! Returns the double precision quotient of two times
1191 
1192 double precision :: time_real_divide
1193 type(time_type), intent(in) :: time1, time2
1194 double precision :: d1, d2
1195 
1197 
1198 ! Convert time intervals to floating point seconds; risky for general performance?
1199 d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + dble(time1%ticks)/dble(ticks_per_second)
1200 d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + dble(time2%ticks)/dble(ticks_per_second)
1201 
1202 time_real_divide = d1 / d2
1203 
1204 end function time_real_divide
1205 ! </FUNCTION>
1206 
1207 !-------------------------------------------------------------------------
1208 ! <SUBROUTINE NAME="time_assignment; assignment(=)">
1209 
1210 ! <OVERVIEW>
1211 ! Assigns all components of the time_type variable on
1212 ! RHS to same components of time_type variable on LHS.
1213 ! </OVERVIEW>
1214 ! <DESCRIPTION>
1215 ! Assigns all components of the time_type variable on
1216 ! RHS to same components of time_type variable on LHS.
1217 ! </DESCRIPTION>
1218 ! <TEMPLATE>
1219 ! time1 = time2
1220 ! </TEMPLATE>
1221 
1222 ! <OUT NAME="time1" UNITS="" TYPE="time_type" DIM="">
1223 ! A time type variable.
1224 ! </OUT>
1225 ! <IN NAME="time2" UNITS="" TYPE="time_type" DIM="">
1226 ! A time type variable.
1227 ! </IN>
1228 
1229 subroutine time_assignment(time1, time2)
1230 type(time_type), intent(out) :: time1
1231 type(time_type), intent(in) :: time2
1232  time1%seconds = time2%seconds
1233  time1%days = time2%days
1234  time1%ticks = time2%ticks
1235 end subroutine time_assignment
1236 ! </SUBROUTINE>
1237 
1238 !-------------------------------------------------------------------------
1239 ! <FUNCTION NAME="time_type_to_real">
1240 ! <OVERVIEW>
1241 ! Converts time to seconds and returns it as a real number
1242 ! </OVERVIEW>
1243 ! <DESCRIPTION>
1244 ! Converts time to seconds and returns it as a real number
1245 ! </DESCRIPTION>
1246 ! <TEMPLATE>
1247 ! time_type_to_real(time)
1248 ! </TEMPLATE>
1249 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
1250 ! A time interval.
1251 ! </IN>
1252 
1253 function time_type_to_real(time)
1255 real(DOUBLE_KIND) :: time_type_to_real
1256 type(time_type), intent(in) :: time
1257 
1259 
1260 time_type_to_real = dble(time%days) * 86400.d0 + dble(time%seconds) + &
1261  dble(time%ticks)/dble(ticks_per_second)
1262 
1263 end function time_type_to_real
1264 ! </FUNCTION>
1265 
1266 !-------------------------------------------------------------------------
1267 ! <FUNCTION NAME="real_to_time_type">
1268 ! <OVERVIEW>
1269 ! Converts a real number of seconds to a time_type variable
1270 ! </OVERVIEW>
1271 ! <DESCRIPTION>
1272 ! Converts a real number of seconds to a time_type variable
1273 ! </DESCRIPTION>
1274 ! <TEMPLATE>
1275 ! real_to_time_type(x, err_msg)
1276 ! </TEMPLATE>
1277 ! <IN NAME="x" UNITS="" TYPE="real" DIM="">
1278 ! A real number of seconds
1279 ! </IN>
1280 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1281 ! When present, and when non-blank, a fatal error condition as been detected.
1282 ! The string itself is an error message.
1283 ! It is recommended that, when err_msg is present in the call
1284 ! to this routine, the next line of code should be something
1285 ! similar to this:
1286 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1287 ! </OUT>
1288 ! <OUT NAME="real_to_time_type" TYPE="time_type">
1289 ! </OUT>
1290 
1291  function real_to_time_type(x, err_msg)
1293  real, intent(in) :: x
1294  character(len=*), intent(out), optional :: err_msg
1295  integer :: seconds, days, ticks
1296  real :: real_ticks
1297  character(len=128) :: err_msg_local
1298 
1300 
1301  days = floor(x/86400.)
1302  seconds = int(x - 86400.*days)
1303  real_ticks = x - int(x)
1304  ticks = nint(real_ticks * ticks_per_second)
1305  if(.not.set_time_private(seconds, days, ticks, real_to_time_type, err_msg_local)) then
1306  if(error_handler('function real_to_time_type', err_msg_local, err_msg)) return
1307  endif
1308 
1309  end function real_to_time_type
1310 ! </FUNCTION>
1311 
1312 !-------------------------------------------------------------------------
1313 ! <FUNCTION NAME="time_scalar_divide; operator(/)">
1314 
1315 ! <OVERVIEW>
1316 ! Returns the largest time, t, for which n * t <= time.
1317 ! </OVERVIEW>
1318 ! <DESCRIPTION>
1319 ! Returns the largest time, t, for which n * t <= time.
1320 ! </DESCRIPTION>
1321 ! <TEMPLATE>
1322 ! time_scalar_divide(time, n)
1323 ! </TEMPLATE>
1324 
1325 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">
1326 ! A time interval.
1327 ! </IN>
1328 ! <IN NAME="n" UNITS="" TYPE="integer" DIM="">
1329 ! An integer factor.
1330 ! </IN>
1331 ! <OUT NAME="" UNITS="" TYPE="integer" DIM="double precision" DEFAULT="">
1332 ! Returns the largest time, t, for which n * t <= time.
1333 ! </OUT>
1334 
1335 function time_scalar_divide(time, n)
1337 ! Returns the largest time, t, for which n * t <= time
1338 
1339 type(time_type) :: time_scalar_divide
1340 type(time_type), intent(in) :: time
1341 integer, intent(in) :: n
1342 double precision :: d, div, dseconds_per_day, dticks_per_second
1343 integer :: days, seconds, ticks
1344 type(time_type) :: prod1, prod2
1345 character(len=128) tmp1,tmp2
1346 logical :: ltmp
1347 
1348 ! Convert time interval to floating point days; risky for general performance?
1349 dseconds_per_day = dble(seconds_per_day)
1350 dticks_per_second = dble(ticks_per_second)
1351 d = time%days*dseconds_per_day*dticks_per_second + dble(time%seconds)*dticks_per_second + dble(time%ticks)
1352 div = d/dble(n)
1353 
1354 days = div/(dseconds_per_day*dticks_per_second)
1355 seconds = div/dticks_per_second - days*dseconds_per_day
1356 ticks = div - (days*dseconds_per_day + dble(seconds))*dticks_per_second
1357 time_scalar_divide = set_time(seconds, days, ticks)
1358 
1359 ! Need to make sure that roundoff isn't killing this
1360 prod1 = n * time_scalar_divide
1361 prod2 = n * (increment_time(time_scalar_divide, days=0, seconds=0, ticks=1))
1362 if(prod1 > time .or. prod2 <= time) then
1363  call get_time(time, seconds, days, ticks)
1364  write(tmp1,20) days,seconds,ticks
1365  call get_time(time_scalar_divide, seconds, days, ticks)
1366  write(tmp2,30) n,days,seconds,ticks
1367  ltmp = error_handler('time_scalar_divide',' quotient error:'//trim(tmp1)//trim(tmp2))
1368  20 format('time=',i7,' days, ',i6,' seconds, ',i6,' ticks')
1369  30 format(' time divided by',i6,'=',i7,' days, ',i6,' seconds, ',i6,' ticks')
1370 endif
1371 
1372 end function time_scalar_divide
1373 ! </FUNCTION>
1374 
1375 !-------------------------------------------------------------------------
1376 ! <FUNCTION NAME="interval_alarm">
1377 
1378 ! <OVERVIEW>
1379 ! Given a time, and a time interval, this function returns true
1380 ! if this is the closest time step to the alarm time.
1381 ! </OVERVIEW>
1382 ! <DESCRIPTION>
1383 ! This is a specialized operation that is frequently performed in models.
1384 ! Given a time, and a time interval, this function is true if this is the
1385 ! closest time step to the alarm time. The actual computation is:
1386 !
1387 ! if((alarm_time - time) &#60;&#61; (time_interval / 2))
1388 !
1389 ! If the function is true, the alarm time is incremented by the
1390 ! alarm_interval; WARNING, this is a featured side effect. Otherwise, the
1391 ! function is false and there are no other effects. CAUTION: if the
1392 ! alarm_interval is smaller than the time_interval, the alarm may fail to
1393 ! return true ever again. Watch
1394 ! for problems if the new alarm time is less than time + time_interval
1395 ! </DESCRIPTION>
1396 ! <TEMPLATE>
1397 ! interval_alarm(time, time_interval, alarm, alarm_interval)
1398 ! </TEMPLATE>
1399 
1400 ! <IN NAME="time" TYPE="time_type"> Current time. </IN>
1401 ! <IN NAME="time_interval" TYPE="time_type"> A time interval. </IN>
1402 ! <IN NAME="alarm_interval" TYPE="time_type"> A time interval. </IN>
1403 ! <OUT NAME="interval_alarm" TYPE="logical">
1404 ! Returns either True or false.
1405 ! </OUT>
1406 ! <INOUT NAME="alarm" TYPE="time_type">
1407 ! An alarm time, which is incremented by the alarm_interval
1408 ! if the function is true.
1409 ! </INOUT>
1410 
1411 function interval_alarm(time, time_interval, alarm, alarm_interval)
1413 ! Supports a commonly used type of test on times for models. Given the
1414 ! current time, and a time for an alarm, determines if this is the closest
1415 ! time to the alarm time given a time step of time_interval. If this
1416 ! is the closest time (alarm - time <= time_interval/2), the function
1417 ! returns true and the alarm is incremented by the alarm_interval. Watch
1418 ! for problems if the new alarm time is less than time + time_interval
1419 
1420 logical :: interval_alarm
1421 type(time_type), intent(in) :: time, time_interval, alarm_interval
1422 type(time_type), intent(inout) :: alarm
1423 
1424 if((alarm - time) <= (time_interval / 2)) then
1425  interval_alarm = .true.
1426  alarm = alarm + alarm_interval
1427 else
1428  interval_alarm = .false.
1429 end if
1430 
1431 end function interval_alarm
1432 ! </FUNCTION>
1433 
1434 !--------------------------------------------------------------------------
1435 ! <FUNCTION NAME="repeat_alarm">
1436 
1437 ! <OVERVIEW>
1438 ! Repeat_alarm supports an alarm that goes off with
1439 ! alarm_frequency and lasts for alarm_length.
1440 ! </OVERVIEW>
1441 ! <DESCRIPTION>
1442 ! Repeat_alarm supports an alarm that goes off with alarm_frequency and
1443 ! lasts for alarm_length. If the nearest occurence of an alarm time
1444 ! is less than half an alarm_length from the input time, repeat_alarm
1445 ! is true. For instance, if the alarm_frequency is 1 day, and the
1446 ! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on
1447 ! day n to time 0100 on day n + 1 for all n.
1448 ! </DESCRIPTION>
1449 ! <TEMPLATE>
1450 ! repeat_alarm(time, alarm_frequency, alarm_length)
1451 ! </TEMPLATE>
1452 
1453 ! <IN NAME="time" TYPE="time_type"> Current time. </IN>
1454 ! <IN NAME="alarm_frequency" TYPE="time_type">
1455 ! A time interval for alarm_frequency.
1456 ! </IN>
1457 ! <IN NAME="alarm_length" TYPE="time_type">
1458 ! A time interval for alarm_length.
1459 ! </IN>
1460 ! <OUT NAME="repeat_alarm" TYPE="logical">
1461 ! Returns either True or false.
1462 ! </OUT>
1463 
1464 function repeat_alarm(time, alarm_frequency, alarm_length)
1466 ! Repeat_alarm supports an alarm that goes off with alarm_frequency and
1467 ! lasts for alarm_length. If the nearest occurence of an alarm time
1468 ! is less than half an alarm_length from the input time, repeat_alarm
1469 ! is true. For instance, if the alarm_frequency is 1 day, and the
1470 ! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on
1471 ! day n to time 0100 on day n + 1 for all n.
1472 
1473 logical :: repeat_alarm
1474 type(time_type), intent(in) :: time, alarm_frequency, alarm_length
1475 type(time_type) :: prev, next
1476 
1477 prev = (time / alarm_frequency) * alarm_frequency
1478 next = prev + alarm_frequency
1479 if(time - prev <= alarm_length / 2 .or. next - time <= alarm_length / 2) then
1480  repeat_alarm = .true.
1481 else
1482  repeat_alarm = .false.
1483 endif
1484 
1485 end function repeat_alarm
1486 ! </FUNCTION>
1487 
1488 !--------------------------------------------------------------------------
1489 
1490 !=========================================================================
1491 ! CALENDAR OPERATIONS BEGIN HERE
1492 !=========================================================================
1493 
1494 ! <SUBROUTINE NAME="set_calendar_type">
1495 
1496 ! <OVERVIEW>
1497 ! Sets the default calendar type for mapping time intervals to dates.
1498 ! </OVERVIEW>
1499 ! <DESCRIPTION>
1500 ! A constant number for setting the calendar type.
1501 ! </DESCRIPTION>
1502 ! <TEMPLATE> set_calendar_type(type, err_msg) </TEMPLATE>
1503 
1504 ! <IN NAME="type" TYPE="integer" DIM="(scalar)" DEFAULT="NO_CALENDAR">
1505 ! A constant number for setting the calendar type.
1506 ! </IN>
1507 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1508 ! When present, and when non-blank, a fatal error condition as been detected.
1509 ! The string itself is an error message.
1510 ! It is recommended that, when err_msg is present in the call
1511 ! to this routine, the next line of code should be something
1512 ! similar to this:
1513 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1514 ! </OUT>
1515 
1516 subroutine set_calendar_type(type, err_msg)
1518 ! Selects calendar for default mapping from time to date.
1519 
1520 integer, intent(in) :: type
1521 character(len=*), intent(out), optional :: err_msg
1522 integer :: iday, days_this_month, year, month, day
1523 logical :: leap
1524 character(len=256) :: err_msg_local
1525 
1527 
1528 if(present(err_msg)) err_msg = ''
1529 
1530 if(type < 0 .or. type > max_type) then
1531  err_msg_local = 'Illegal calendar type'
1532  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
1533 endif
1534 
1535 if(seconds_per_day /= 86400 .and. type /= no_calendar ) then
1536  err_msg_local = 'Only calendar type NO_CALENDAR is allowed when seconds_per_day is not 86400.'// &
1537  ' You are using '//trim(valid_calendar_types(type))//' and seconds_per_day='
1538  write(err_msg_local(len_trim(err_msg_local)+1:len_trim(err_msg_local)+8),'(i8)') seconds_per_day
1539  if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return
1540 endif
1541 
1542 calendar_type = type
1543 
1544 if(type == gregorian) then
1546  iday = 0
1547  do year=1,400
1548  leap = leap_year_gregorian_int(year)
1549  do month=1,12
1550  days_this_month = days_per_month(month)
1551  if(leap .and. month ==2) days_this_month = 29
1552  do day=1,days_this_month
1553  date_to_day(year,month,day) = iday
1554  iday = iday+1
1555  coded_date(iday) = day + 32*(month + 16*year)
1556  enddo ! do day
1557  enddo ! do month
1558  enddo ! do year
1559 endif
1560 
1561 end subroutine set_calendar_type
1562 ! </SUBROUTINE>
1563 
1564 !------------------------------------------------------------------------
1565 ! <FUNCTION NAME="get_calendar_type">
1566 
1567 ! <OVERVIEW>
1568 ! Returns the value of the default calendar type for mapping
1569 ! from time to date.
1570 ! </OVERVIEW>
1571 ! <DESCRIPTION>
1572 ! There are no arguments in this function. It returns the value of
1573 ! the default calendar type for mapping from time to date.
1574 ! </DESCRIPTION>
1575 ! <TEMPLATE>
1576 ! get_calendar_type()
1577 ! </TEMPLATE>
1578 
1579 function get_calendar_type()
1581 ! Returns default calendar type for mapping from time to date.
1582 
1583 integer :: get_calendar_type
1584 
1586 
1587 end function get_calendar_type
1588 ! </FUNCTION>
1589 
1590 !------------------------------------------------------------------------
1591 ! <SUBROUTINE NAME="set_ticks_per_second">
1592 
1593 ! <OVERVIEW>
1594 ! Sets the number of ticks per second.
1595 ! </OVERVIEW>
1596 ! <DESCRIPTION>
1597 ! Sets the number of ticks per second.
1598 ! </DESCRIPTION>
1599 ! <TEMPLATE> call set_ticks_per_second(ticks_per_second) </TEMPLATE>
1600 ! <IN NAME="type" TYPE="integer" DIM="(scalar)" DEFAULT="1"> </IN>
1601 
1602 subroutine set_ticks_per_second(tps)
1603 integer, intent(in) :: tps
1604 
1605 ticks_per_second = tps
1606 
1607 end subroutine set_ticks_per_second
1608 
1609 ! </SUBROUTINE>
1610 
1611 !------------------------------------------------------------------------
1612 ! <FUNCTION NAME="get_ticks_per_second">
1613 
1614 ! <OVERVIEW>
1615 ! Returns the number of ticks per second.
1616 ! </OVERVIEW>
1617 ! <DESCRIPTION>
1618 ! Returns the number of ticks per second.
1619 ! </DESCRIPTION>
1620 ! <TEMPLATE>
1621 ! ticks_per_second = get_ticks_per_second()
1622 ! </TEMPLATE>
1623 
1624 function get_ticks_per_second()
1626 
1628 
1629 end function get_ticks_per_second
1630 
1631 ! </FUNCTION>
1632 !------------------------------------------------------------------------
1633 
1634 !========================================================================
1635 ! START OF get_date BLOCK
1636 ! <SUBROUTINE NAME="get_date">
1637 
1638 ! <OVERVIEW>
1639 ! Given a time_interval, returns the corresponding date under
1640 ! the selected calendar.
1641 ! </OVERVIEW>
1642 ! <DESCRIPTION>
1643 ! Given a time_interval, returns the corresponding date under
1644 ! the selected calendar.
1645 ! </DESCRIPTION>
1646 ! <TEMPLATE>
1647 ! get_date(time, year, month, day, hour, minute, second, tick, err_msg)
1648 ! </TEMPLATE>
1649 ! <IN NAME="time" TYPE="time_type"> A time interval.</IN>
1650 ! <OUT NAME="year" TYPE="integer"></OUT>
1651 ! <OUT NAME="month" TYPE="integer"></OUT>
1652 ! <OUT NAME="day" TYPE="integer"></OUT>
1653 ! <OUT NAME="hour" TYPE="integer"></OUT>
1654 ! <OUT NAME="minute" TYPE="integer"></OUT>
1655 ! <OUT NAME="second" TYPE="integer"></OUT>
1656 ! <OUT NAME="tick" TYPE="integer, optional"></OUT>
1657 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1658 ! When present, and when non-blank, a fatal error condition as been detected.
1659 ! The string itself is an error message.
1660 ! It is recommended that, when err_msg is present in the call
1661 ! to this routine, the next line of code should be something
1662 ! similar to this:
1663 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1664 ! </OUT>
1665  subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg)
1667 ! Given a time, computes the corresponding date given the selected calendar
1668 
1669  type(time_type), intent(in) :: time
1670  integer, intent(out) :: second, minute, hour, day, month, year
1671  integer, intent(out), optional :: tick
1672  character(len=*), intent(out), optional :: err_msg
1673  character(len=128) :: err_msg_local
1674  integer :: tick1
1675 
1677  if(present(err_msg)) err_msg = ''
1678 
1679  select case(calendar_type)
1680  case(thirty_day_months)
1681  call get_date_thirty (time, year, month, day, hour, minute, second, tick1)
1682  case(gregorian)
1683  call get_date_gregorian(time, year, month, day, hour, minute, second, tick1)
1684  case(julian)
1685  call get_date_julian_private (time, year, month, day, hour, minute, second, tick1)
1686  case(noleap)
1687  call get_date_no_leap_private (time, year, month, day, hour, minute, second, tick1)
1688  case(no_calendar)
1689  err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR'
1690  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1691  case default
1692  err_msg_local = 'Invalid calendar type'
1693  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1694  end select
1695 
1696  if(present(tick)) then
1697  tick = tick1
1698  else
1699  if(tick1 /= 0) then
1700  err_msg_local = 'tick must be present when time has a second fraction'
1701  if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
1702  endif
1703  endif
1704 
1705  end subroutine get_date
1706 ! </SUBROUTINE>
1707 !------------------------------------------------------------------------
1708 
1709  subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)
1711 ! Computes date corresponding to time for gregorian calendar
1712 
1713  type(time_type), intent(in) :: time
1714  integer, intent(out) :: year, month, day, hour, minute, second
1715  integer, intent(out) :: tick
1716  integer :: iday, isec
1717 
1718  if(time%seconds >= 86400) then ! This check appears to be unecessary.
1719  call error_mesg('get_date',.ge.'Time%seconds 86400 in subroutine get_date_gregorian',fatal)
1720  endif
1721 
1722  iday = mod(time%days+1,days_in_400_year_period)
1723  if(iday == 0) iday = days_in_400_year_period
1724 
1725  year = coded_date(iday)/512
1726  day = mod(coded_date(iday),32)
1727  month = coded_date(iday)/32 - 16*year
1728 
1729  year = year + 400*((time%days)/days_in_400_year_period)
1730 
1731  hour = time%seconds / 3600
1732  isec = time%seconds - 3600*hour
1733  minute = isec / 60
1734  second = isec - 60*minute
1735  tick = time%ticks
1736 
1737  end subroutine get_date_gregorian
1738 
1739 !------------------------------------------------------------------------
1740  function cut0(string)
1741  character(len=256) :: cut0
1742  character(len=*), intent(in) :: string
1743  integer :: i
1744 
1745  cut0 = string
1746 
1747  do i=1,len(string)
1748  if(ichar(string(i:i)) == 0 ) then
1749  cut0(i:i) = ' '
1750  endif
1751  enddo
1752 
1753  return
1754  end function cut0
1755 !------------------------------------------------------------------------
1756 
1757  subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)
1759 ! Base date for Julian calendar is year 1 with all multiples of 4
1760 ! years being leap years.
1761 
1762  type(time_type), intent(in) :: time
1763  integer, intent(out) :: second, minute, hour, day, month, year
1764  integer, intent(out) :: tick
1765  integer :: m, t, nfour, nex, days_this_month
1766  logical :: leap
1767 
1768 ! find number of four year periods; also get modulo number of days
1769  nfour = time%days / (4 * 365 + 1)
1770  day = modulo(time%days, (4 * 365 + 1))
1771 
1772 ! Find out what year in four year chunk
1773  nex = day / 365
1774  if(nex == 4) then
1775  nex = 3
1776  day = 366
1777  else
1778  day=modulo(day, 365) + 1
1779  endif
1780 
1781 ! Is this a leap year?
1782  leap = (nex == 3)
1783 
1784  year = 1 + 4 * nfour + nex
1785 
1786 ! find month and day
1787  do m = 1, 12
1788  month = m
1789  days_this_month = days_per_month(m)
1790  if(leap .and. m == 2) days_this_month = 29
1791  if(day <= days_this_month) exit
1792  day = day - days_this_month
1793  end do
1794 
1795 ! find hour,minute and second
1796  t = time%seconds
1797  hour = t / (60 * 60)
1798  t = t - hour * (60 * 60)
1799  minute = t / 60
1800  second = t - 60 * minute
1801  tick = time%ticks
1802  end subroutine get_date_julian_private
1803 
1804 !------------------------------------------------------------------------
1805  subroutine get_date_julian(time, year, month, day, hour, minute, second)
1807 ! No need to include tick in argument list because this routine
1808 ! exists only for interpolator.F90, which does not need it.
1809 
1810  type(time_type), intent(in) :: time
1811  integer, intent(out) :: second, minute, hour, day, month, year
1812  integer :: tick
1813 
1814  call get_date_julian_private(time, year, month, day, hour, minute, second, tick)
1815 
1816  end subroutine get_date_julian
1817 
1818 !------------------------------------------------------------------------
1819 
1820  subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
1822 ! Computes date corresponding to time interval for 30 day months, 12
1823 ! month years.
1824 
1825  type(time_type), intent(in) :: time
1826  integer, intent(out) :: second, minute, hour, day, month, year
1827  integer, intent(out) :: tick
1828  integer :: t, dmonth, dyear
1829 
1830  t = time%days
1831  dyear = t / (30 * 12)
1832  year = dyear + 1
1833  t = t - dyear * (30 * 12)
1834  dmonth = t / 30
1835  month = 1 + dmonth
1836  day = t -dmonth * 30 + 1
1837 
1838  t = time%seconds
1839  hour = t / (60 * 60)
1840  t = t - hour * (60 * 60)
1841  minute = t / 60
1842  second = t - 60 * minute
1843  tick = time%ticks
1844 
1845  end subroutine get_date_thirty
1846 !------------------------------------------------------------------------
1847 
1848  subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
1850 ! Base date for NOLEAP calendar is year 1.
1851 
1852  type(time_type), intent(in) :: time
1853  integer, intent(out) :: second, minute, hour, day, month, year
1854  integer, intent(out) :: tick
1855  integer :: m, t
1856 
1857 ! get modulo number of days
1858  year = time%days / 365 + 1
1859  day = modulo(time%days, 365) + 1
1860 
1861 ! find month and day
1862  do m = 1, 12
1863  month = m
1864  if(day <= days_per_month(m)) exit
1865  day = day - days_per_month(m)
1866  end do
1867 
1868 ! find hour,minute and second
1869  t = time%seconds
1870  hour = t / (60 * 60)
1871  t = t - hour * (60 * 60)
1872  minute = t / 60
1873  second = t - 60 * minute
1874  tick = time%ticks
1875 
1876  end subroutine get_date_no_leap_private
1877 
1878 !------------------------------------------------------------------------
1879  subroutine get_date_no_leap(time, year, month, day, hour, minute, second)
1881 ! No need to include tick in argument list because this routine
1882 ! exists only for interpolator.F90, which does not need it.
1883 
1884  type(time_type), intent(in) :: time
1885  integer, intent(out) :: second, minute, hour, day, month, year
1886  integer :: tick
1887 
1888  call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
1889 
1890  end subroutine get_date_no_leap
1891 !------------------------------------------------------------------------
1892 
1893 ! END OF get_date BLOCK
1894 !========================================================================
1895 ! START OF set_date BLOCK
1896 ! <FUNCTION NAME="set_date">
1897 
1898 ! <OVERVIEW>
1899 ! Given an input date in year, month, days, etc., creates a
1900 ! time_type that represents this time interval from the
1901 ! internally defined base date.
1902 ! </OVERVIEW>
1903 ! <DESCRIPTION>
1904 ! Given a date, computes the corresponding time given the selected
1905 ! date time mapping algorithm. Note that it is possible to specify
1906 ! any number of illegal dates; these should be checked for and generate
1907 ! errors as appropriate.
1908 ! </DESCRIPTION>
1909 ! <TEMPLATE>
1910 ! 1. set_date(year, month, day, hours, minute, second, tick, err_msg)
1911 ! </TEMPLATE>
1912 ! <TEMPLATE>
1913 ! 2. set_date_c(time_string, zero_year_warning, err_msg, allow_rounding)
1914 ! time_string is a character string containing a date formatted
1915 ! according to CF conventions. e.g. '1980-12-31 23:59:59.9'
1916 ! </TEMPLATE>
1917 ! <IN NAME="time" TYPE="time_type"> A time interval.</IN>
1918 ! <IN NAME="year" TYPE="integer"></IN>
1919 ! <IN NAME="month" TYPE="integer"></IN>
1920 ! <IN NAME="day" TYPE="integer"></IN>
1921 ! <IN NAME="hour" TYPE="integer"></IN>
1922 ! <IN NAME="minute" TYPE="integer"></IN>
1923 ! <IN NAME="second" TYPE="integer"></IN>
1924 ! <IN NAME="tick" TYPE="integer"></IN>
1925 ! <IN NAME="zero_year_warning" TYPE="logical">
1926 ! If the year number is zero, it will be silently changed to one,
1927 ! unless zero_year_warning=.true., in which case a WARNING message
1928 ! will also be issued.
1929 ! </IN>
1930 ! <IN NAME="allow_rounding" TYPE="logical, optional" DEFAULT=".true.">
1931 ! When .true., any fractions of a second will be rounded off to the nearest tick.
1932 ! When .false., it is a fatal error if the second fraction cannot be exactly
1933 ! represented by a number of ticks.
1934 ! </IN>
1935 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
1936 ! When present, and when non-blank, a fatal error condition as been detected.
1937 ! The string itself is an error message.
1938 ! It is recommended that, when err_msg is present in the call
1939 ! to this routine, the next line of code should be something
1940 ! similar to this:
1941 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
1942 ! </OUT>
1943 ! <OUT NAME="set_date" TYPE="time_type"> A time interval.</OUT>
1944 
1945  function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
1947 ! Given a date, computes the corresponding time given the selected
1948 ! date time mapping algorithm. Note that it is possible to specify
1949 ! any number of illegal dates; these are checked for and generate
1950 ! errors as appropriate.
1951 
1952  logical :: set_date_private
1953  integer, intent(in) :: year, month, day, hour, minute, second, tick
1954  type(time_type) :: time_out
1955  character(len=*), intent(out) :: err_msg
1956 
1958 
1959  err_msg = ''
1960 
1961  select case(calendar_type)
1962  case(thirty_day_months)
1963  set_date_private = set_date_thirty(year, month, day, hour, minute, second, tick, time_out, err_msg)
1964  case(gregorian)
1965  set_date_private = set_date_gregorian(year, month, day, hour, minute, second, tick, time_out, err_msg)
1966  case(julian)
1967  set_date_private = set_date_julian_private(year, month, day, hour, minute, second, tick, time_out, err_msg)
1968  case(noleap)
1969  set_date_private = set_date_no_leap_private(year, month, day, hour, minute, second, tick, time_out, err_msg)
1970  case (no_calendar)
1971  err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR'
1972  set_date_private = .false.
1973  case default
1974  err_msg = 'Invalid calendar type'
1975  set_date_private = .false.
1976  end select
1977 
1978  end function set_date_private
1979 ! </FUNCTION>
1980 
1981 !------------------------------------------------------------------------
1982  function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
1984  integer, intent(in) :: day, month, year
1985  integer, intent(in), optional :: second, minute, hour, tick
1986  character(len=*), intent(out), optional :: err_msg
1987  integer :: osecond, ominute, ohour, otick
1988  character(len=128) :: err_msg_local
1989 
1991  if(present(err_msg)) err_msg = ''
1992 
1993 ! Missing optionals are set to 0
1994  osecond = 0; if(present(second)) osecond = second
1995  ominute = 0; if(present(minute)) ominute = minute
1996  ohour = 0; if(present(hour)) ohour = hour
1997  otick = 0; if(present(tick)) otick = tick
1998 
1999  if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local)) then
2000  if(error_handler('function set_date_i', err_msg_local, err_msg)) return
2001  endif
2002 
2003  end function set_date_i
2004 !------------------------------------------------------------------------
2005 
2006  function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
2008  ! Examples of acceptable forms of string:
2009 
2010  ! 1980-01-01 00:00:00
2011  ! 1980-01-01 00:00:00.50
2012  ! 1980-1-1 0:0:0
2013  ! 1980-1-1
2014 
2015  ! year number must occupy 4 spaces.
2016  ! months, days, hours, minutes, seconds may occupy 1 or 2 spaces
2017  ! year, month and day must be separated by a '-'
2018  ! hour, minute, second must be separated by a ':'
2019  ! hour, minute, second are optional. If not present then zero is assumed.
2020  ! second may be a real number.
2021 
2022  ! zero_year_warning:
2023  ! If the year number is zero, it will be silently changed to one,
2024  ! unless zero_year_warning=.true., in which case a WARNING message
2025  ! will also be issued
2026 
2027  type(time_type) :: set_date_c
2028  character(len=*), intent(in) :: string
2029  logical, intent(in), optional :: zero_year_warning
2030  character(len=*), intent(out), optional :: err_msg
2031  logical, intent(in), optional :: allow_rounding
2032  character(len=4) :: formt='(i )'
2033  logical :: correct_form, zero_year_warning_local, allow_rounding_local
2034  integer :: i1, i2, i3, i4, i5, i6, i7
2035  character(len=32) :: string_sifted_left
2036  integer :: year, month, day, hour, minute, second, tick
2037  character(len=128) :: err_msg_local
2038 
2040  if(present(err_msg)) err_msg = ''
2041  if(present(zero_year_warning)) then
2042  zero_year_warning_local = zero_year_warning
2043  else
2044  zero_year_warning_local = .true.
2045  endif
2046  if(present(allow_rounding)) then
2047  allow_rounding_local = allow_rounding
2048  else
2049  allow_rounding_local = .true.
2050  endif
2051 
2052  string_sifted_left = adjustl(string)
2053  i1 = index(string_sifted_left,'-')
2054  i2 = index(string_sifted_left,'-',back=.true.)
2055  i3 = index(string_sifted_left,':')
2056  i4 = index(string_sifted_left,':',back=.true.)
2057  i5 = len_trim(cut0(string_sifted_left))
2058  i6 = index(string_sifted_left,'.',back=.true.)
2059  correct_form = (i1 > 1) ! year number must occupy at least 1 space
2060  correct_form = correct_form .and. (i2-i1 == 2 .or. i2-i1 == 3) ! month number must occupy 1 or 2 spaces
2061  if(.not.correct_form) then
2062  err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string)
2063  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
2064  endif
2065  write(formt(3:3),'(i1)') i1-1
2066  read(string_sifted_left(1:i1-1),formt) year
2067  if(year == 0) then
2068  year = 1
2069  if(zero_year_warning_local) then
2070  call error_mesg('set_date_c','Year zero is invalid. Resetting year to 1', warning)
2071  endif
2072  endif
2073  write(formt(3:3),'(i1)') i2-i1-1
2074  read(string_sifted_left(i1+1:i2-1),formt) month
2075  i7 = min(i2+2,i5)
2076  read(string_sifted_left(i2+1:i7),'(i2)') day
2077 
2078  if(i3 == 0) then
2079 ! There are no minutes or seconds in the string
2080  minute = 0
2081  second = 0
2082  tick = 0
2083  if(i5 <= i2+2) then
2084  ! There is no clocktime in the string at all
2085  hour = 0
2086  else
2087  ! The clocktime includes only hours
2088  read(string_sifted_left(i5-1:i5),'(i2)') hour
2089  endif
2090  else if(i3 == i4) then
2091  ! The string includes hours and minutes, but no seconds
2092  read(string_sifted_left(i3-2:i3-1),'(i2)') hour
2093  write(formt(3:3),'(i1)') i5-i3
2094  read(string_sifted_left(i3+1:i5),formt) minute
2095  second = 0
2096  tick = 0
2097  else
2098  ! The string includes hours, minutes, and seconds
2099  read(string_sifted_left(i3-2:i3-1),'(i2)') hour
2100  write(formt(3:3),'(i1)') i4-i3-1
2101  read(string_sifted_left(i3+1:i4-1),formt) minute
2102  write(formt(3:3),'(i1)') i5-i4
2103  if(i6 == 0) then
2104  ! There are no fractional seconds
2105  read(string_sifted_left(i4+1:i5),formt) second
2106  tick = 0
2107  else
2108  read(string_sifted_left(i4+1:i6-1),formt) second
2109  if(.not.get_tick_from_string(string_sifted_left(i6:i5), err_msg_local, allow_rounding_local, tick)) then
2110  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
2111  endif
2112  ! If tick has been rounded up to ticks_per_second, then bump up second.
2113  if(tick == ticks_per_second) then
2114  second = second + 1
2115  tick = 0
2116  endif
2117  endif
2118  endif
2119 
2120  if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local)) then
2121  if(error_handler('function set_date_c', err_msg_local, err_msg)) return
2122  endif
2123 
2124  end function set_date_c
2125 !------------------------------------------------------------------------
2126 
2127  function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2129 
2130 ! Computes time corresponding to date for gregorian calendar.
2131 
2132  integer, intent(in) :: year, month, day, hour, minute, second, tick
2133  type(time_type), intent(out) :: time_out
2134  character(len=*), intent(out) :: err_msg
2135  integer :: yr1, day1
2136 
2137  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
2138  set_date_gregorian = .false.
2139  return
2140  endif
2141 
2142  time_out%seconds = second + 60*(minute + 60*hour)
2143 
2144  yr1 = mod(year,400)
2145  if(yr1 == 0) yr1 = 400
2146  day1 = date_to_day(yr1,month,day)
2147  if(day1 == invalid_date) then
2148  err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2149  set_date_gregorian = .false.
2150  return
2151  endif
2152 
2153  time_out%days = day1 + days_in_400_year_period*((year-1)/400)
2154  time_out%ticks = tick
2155  err_msg = ''
2156  set_date_gregorian = .true.
2157 
2158  end function set_date_gregorian
2159 
2160 !------------------------------------------------------------------------
2161 
2162  function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2164 
2165 ! Returns time corresponding to date for julian calendar.
2166 
2167  integer, intent(in) :: year, month, day, hour, minute, second, tick
2168  type(time_type), intent(out) :: time_out
2169  character(len=*), intent(out) :: err_msg
2170  integer :: ndays, m, nleapyr
2171  logical :: leap
2172 
2173  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
2174  set_date_julian_private = .false.
2175  return
2176  endif
2177 
2178  if(month /= 2 .and. day > days_per_month(month)) then
2179  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2180  set_date_julian_private = .false.
2181  return
2182  endif
2183 
2184 ! Is this a leap year?
2185  leap = (modulo(year,4) == 0)
2186 ! compute number of complete leap years from year 1
2187  nleapyr = (year - 1) / 4
2188 
2189 ! Finish checking for day specication errors
2190  if(month == 2 .and. (day > 29 .or. ((.not. leap) .and. day > 28))) then
2191  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2192  set_date_julian_private = .false.
2193  return
2194  endif
2195 
2196  ndays = 0
2197  do m = 1, month - 1
2198  ndays = ndays + days_per_month(m)
2199  if(leap .and. m == 2) ndays = ndays + 1
2200  enddo
2201 
2202  time_out%seconds = second + 60 * (minute + 60 * hour)
2203  time_out%days = day -1 + ndays + 365*(year - nleapyr - 1) + 366*(nleapyr)
2204  time_out%ticks = tick
2205  err_msg = ''
2206  set_date_julian_private = .true.
2207 
2208  end function set_date_julian_private
2209 
2210 !------------------------------------------------------------------------
2211  function set_date_julian(year, month, day, hour, minute, second)
2213 ! No need to include tick or err_msg in argument list because this
2214 ! routine exists only for interpolator.F90, which does not need them.
2215 
2216  type(time_type) :: set_date_julian
2217  integer, intent(in) :: year, month, day, hour, minute, second
2218  character(len=128) :: err_msg
2219 
2220  if(.not.set_date_julian_private(year, month, day, hour, minute, second, 0, set_date_julian, err_msg)) then
2221  call error_mesg('set_date_julian',trim(err_msg),fatal)
2222  endif
2223 
2224  end function set_date_julian
2225 !------------------------------------------------------------------------
2226 
2227  function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2228  logical :: set_date_thirty
2229 
2230 ! Computes time corresponding to date for thirty day months.
2231 
2232  integer, intent(in) :: year, month, day, hour, minute, second, tick
2233  type(time_type), intent(out) :: time_out
2234  character(len=*), intent(out) :: err_msg
2235 
2236  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
2237  set_date_thirty = .false.
2238  return
2239  endif
2240 
2241  if(day > 30) then
2242  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2243  set_date_thirty = .false.
2244  return
2245  endif
2246 
2247  time_out%days = (day - 1) + 30 * ((month - 1) + 12 * (year - 1))
2248  time_out%seconds = second + 60 * (minute + 60 * hour)
2249  time_out%ticks = tick
2250  err_msg = ''
2251  set_date_thirty = .true.
2252 
2253  end function set_date_thirty
2254 
2255 !------------------------------------------------------------------------
2256 
2257  function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
2259 
2260 ! Computes time corresponding to date for fixed 365 day year calendar.
2261 
2262  integer, intent(in) :: year, month, day, hour, minute, second, tick
2263  type(time_type), intent(out) :: time_out
2264  character(len=*), intent(out) :: err_msg
2265  integer :: ndays, m
2266 
2267  if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
2268  set_date_no_leap_private = .false.
2269  return
2270  endif
2271 
2272  if(day > days_per_month(month)) then
2273  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2274  set_date_no_leap_private = .false.
2275  return
2276  endif
2277 
2278  ndays = 0
2279  do m = 1, month - 1
2280  ndays = ndays + days_per_month(m)
2281  enddo
2282 
2283 ! No need for err_msg in call to set_time because previous checks ensure positive value of time.
2284  time_out = set_time(second + 60 * (minute + 60 * hour), day -1 + ndays + 365 * (year - 1), tick)
2285  err_msg = ''
2286  set_date_no_leap_private = .true.
2287 
2288  end function set_date_no_leap_private
2289 !------------------------------------------------------------------------
2290 
2291  function set_date_no_leap(year, month, day, hour, minute, second)
2293 ! No need to include tick or err_msg in argument list because this
2294 ! routine exists only for interpolator.F90, which does not need them.
2295 
2296  type(time_type) :: set_date_no_leap
2297  integer, intent(in) :: year, month, day, hour, minute, second
2298  character(len=128) :: err_msg
2299 
2300  if(.not.set_date_no_leap_private(year, month, day, hour, minute, second, 0, set_date_no_leap, err_msg)) then
2301  call error_mesg('set_date_no_leap',trim(err_msg),fatal)
2302  endif
2303 
2304  end function set_date_no_leap
2305 
2306 !=========================================================================
2307 
2308  function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
2309  logical :: valid_increments
2310  integer, intent(in) :: year, month, day, hour, minute, second, tick
2311  character(len=128), intent(out) :: err_msg
2312 
2313 ! Check for invalid values
2314 
2315  err_msg = ''
2316  valid_increments = .true.
2317  if(second > 59 .or. second < 0 .or. minute > 59 .or. minute < 0 &
2318  .or. hour > 23 .or. hour < 0 .or. day > 31 .or. day < 1 &
2319  .or. month > 12 .or. month < 1 .or. year < 1) then
2320  err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
2321  valid_increments = .false.
2322  return
2323  endif
2324  if(tick < 0 .or. tick >= ticks_per_second) then
2325  write(err_msg,'(a,i6)') 'Invalid number of ticks. tick=',tick
2326  valid_increments = .false.
2327  endif
2328 
2329  end function valid_increments
2330 
2331 !=========================================================================
2332 
2333  function convert_integer_date_to_char(year, month, day, hour, minute, second)
2334  character(len=19) :: convert_integer_date_to_char
2335  integer, intent(in) :: year, month, day
2336  integer, intent(in) :: hour, minute, second
2337 
2338  write(convert_integer_date_to_char,10) year,month,day,hour,minute,second
2339  10 format(i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2)
2340 
2341  end function convert_integer_date_to_char
2342 
2343 !=========================================================================
2344 ! END OF set_date BLOCK
2345 !=========================================================================
2346 
2347 ! <FUNCTION NAME="increment_date">
2348 
2349 ! <OVERVIEW>
2350 ! Increments the date represented by a time interval and the
2351 ! default calendar type by a number of seconds, etc.
2352 ! </OVERVIEW>
2353 ! <DESCRIPTION>
2354 ! Given a time and some date increment, computes a new time. Depending
2355 ! on the mapping algorithm from date to time, it may be possible to specify
2356 ! undefined increments (i.e. if one increments by 68 days and 3 months in
2357 ! a Julian calendar, it matters which order these operations are done and
2358 ! we don't want to deal with stuff like that, make it an error).
2359 ! </DESCRIPTION>
2360 ! <TEMPLATE>
2361 ! increment_date(time, years, months, days, hours, minutes, seconds, ticks, err_msg)
2362 ! </TEMPLATE>
2363 ! <IN NAME="time" TYPE="time_type"> A time interval.</IN>
2364 ! <IN NAME="years" TYPE="integer">An increment of years.</IN>
2365 ! <IN NAME="months" TYPE="integer">An increment of months.</IN>
2366 ! <IN NAME="days" TYPE="integer">An increment of days.</IN>
2367 ! <IN NAME="hours" TYPE="integer">An increment of hours.</IN>
2368 ! <IN NAME="minutes" TYPE="integer">An increment of minutes.</IN>
2369 ! <IN NAME="seconds" TYPE="integer">An increment of seconds.</IN>
2370 ! <IN NAME="ticks" TYPE="integer">An increment of ticks.</IN>
2371 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
2372 ! When present, and when non-blank, a fatal error condition as been detected.
2373 ! The string itself is an error message.
2374 ! It is recommended that, when err_msg is present in the call
2375 ! to this routine, the next line of code should be something
2376 ! similar to this:
2377 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
2378 ! </OUT>
2379 ! <OUT NAME="increment_date" TYPE="time_type"> A new time based on the input
2380 ! time interval and the calendar type.
2381 ! </OUT>
2382 ! <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
2383 ! When .false., it is a fatal error if any of the input time increments are negative.
2384 ! This mimics the behavior of lima and earlier revisions.
2385 ! </IN>
2386 ! <NOTE>
2387 ! For all but the thirty_day_months calendar, increments to months
2388 ! and years must be made separately from other units because of the
2389 ! non-associative nature of addition.
2390 ! If the result is a negative time (i.e. date before the base date)
2391 ! it is considered a fatal error.
2392 ! </NOTE>
2393 
2394  function increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
2396 ! Given a time and some date increment, computes a new time. Depending
2397 ! on the mapping algorithm from date to time, it may be possible to specify
2398 ! undefined increments (i.e. if one increments by 68 days and 3 months in
2399 ! a Julian calendar, it matters which order these operations are done and
2400 ! we don't want to deal with stuff like that, make it an error).
2401 
2402 ! This routine operates in one of two modes.
2403 ! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
2404 ! 2. years and/or months are incremented, other time increments must be zero or absent arguments.
2405 
2406  type(time_type) :: increment_date
2407  type(time_type), intent(in) :: time
2408  integer, intent(in), optional :: years, months, days, hours, minutes, seconds, ticks
2409  character(len=*), intent(out), optional :: err_msg
2410  logical, intent(in), optional :: allow_neg_inc
2411 
2412  integer :: oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2413  character(len=128) :: err_msg_local
2414  logical :: allow_neg_inc_local
2415 
2417  if(present(err_msg)) err_msg = ''
2418 
2419 ! Missing optionals are set to 0
2420  oseconds = 0; if(present(seconds)) oseconds = seconds
2421  ominutes = 0; if(present(minutes)) ominutes = minutes
2422  ohours = 0; if(present(hours)) ohours = hours
2423  odays = 0; if(present(days)) odays = days
2424  omonths = 0; if(present(months)) omonths = months
2425  oyears = 0; if(present(years)) oyears = years
2426  oticks = 0; if(present(ticks)) oticks = ticks
2427  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
2428 
2429  if(.not.allow_neg_inc_local) then
2430  if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then
2431  write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2432  if(error_handler('function increment_time', err_msg_local, err_msg)) return
2433  endif
2434  endif
2435  10 format('One or more time increments are negative: '// &
2436  'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)
2437 
2438  if(.not.increment_date_private( &
2439  time, oyears, omonths, odays, ohours, ominutes, oseconds, oticks, increment_date, err_msg_local)) then
2440  if(error_handler('function increment_date', err_msg_local, err_msg)) return
2441  endif
2442 
2443  end function increment_date
2444 
2445 ! </FUNCTION>
2446 
2447 !=======================================================================
2448 
2449  function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
2451 ! Given a time and some date increment, computes a new time. Depending
2452 ! on the mapping algorithm from date to time, it may be possible to specify
2453 ! undefined increments (i.e. if one increments by 68 days and 3 months in
2454 ! a Julian calendar, it matters which order these operations are done and
2455 ! we don't want to deal with stuff like that, make it an error).
2456 
2457 ! This routine operates in one of two modes.
2458 ! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments.
2459 ! 2. years and/or months are incremented, other time increments must be zero or absent arguments.
2460 
2461 ! Negative increments are always allowed in the private version of this routine.
2462 
2463  logical :: increment_date_private
2464  type(time_type), intent(in) :: time
2465  integer, intent(in) :: years, months, days, hours, minutes, seconds, ticks
2466  type(time_type), intent(out) :: time_out
2467  character(len=*), intent(out) :: err_msg
2468  integer :: cyear , cmonth , cday , chour , cminute , csecond , ctick
2469  logical :: mode_1, mode_2
2470 
2471  err_msg = ''
2472  increment_date_private = .true.
2473 
2474  mode_1 = days /= 0 .or. hours /= 0 .or. minutes /= 0 .or. seconds /= 0 .or. ticks /= 0
2475  mode_2 = years /= 0 .or. months /= 0
2476 
2477  if(.not.mode_1 .and. .not.mode_2) then
2478  ! All time increments are zero
2479  time_out = time
2480  return
2481  endif
2482 
2483  if(mode_1 .and. mode_2) then
2484  err_msg = 'years and/or months must not be incremented with other time units'
2485  increment_date_private = .false.
2486  return
2487  endif
2488 
2489  if(mode_1) then
2490  csecond = seconds + 60 * (minutes + 60 * hours)
2491  increment_date_private = increment_time_private(time, csecond, days, ticks, time_out, err_msg)
2492  endif
2493 
2494  if(mode_2) then
2495  ! Convert Time to a date
2496  select case(calendar_type)
2497  case(thirty_day_months)
2498  call get_date_thirty (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2499  case(noleap)
2500  call get_date_no_leap_private (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2501  case(julian)
2502  call get_date_julian_private (time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2503  case(gregorian)
2504  call get_date_gregorian(time, cyear, cmonth, cday, chour, cminute, csecond, ctick)
2505  case(no_calendar)
2506  err_msg = 'Cannot increment a date when the calendar type is NO_CALENDAR'
2507  increment_date_private = .false.
2508  return
2509  case default
2510  err_msg = 'Invalid calendar type'
2511  increment_date_private = .false.
2512  return
2513  end select
2514 
2515  ! Add month increment
2516  cmonth = cmonth + months
2517 
2518  ! Adjust year and month number when cmonth falls outside the range 1 to 12
2519  cyear = cyear + floor((cmonth-1)/12.)
2520  cmonth = modulo((cmonth-1),12) + 1
2521 
2522  ! Add year increment
2523  cyear = cyear + years
2524 
2525  ! Convert this back into a time.
2526  select case(calendar_type)
2527  case(thirty_day_months)
2528  increment_date_private = set_date_thirty(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, err_msg)
2529  case(noleap)
2530  increment_date_private = set_date_no_leap_private(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, err_msg)
2531  case(julian)
2532  increment_date_private = set_date_julian_private(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, err_msg)
2533  case(gregorian)
2534  increment_date_private = set_date_gregorian(cyear, cmonth, cday, chour, cminute, csecond, ctick, time_out, err_msg)
2535  end select
2536  endif ! if(mode_2)
2537 
2538  end function increment_date_private
2539 
2540 !=========================================================================
2541 ! <FUNCTION NAME="decrement_date">
2542 
2543 ! <OVERVIEW>
2544 ! Decrements the date represented by a time interval and the
2545 ! default calendar type by a number of seconds, etc.
2546 ! </OVERVIEW>
2547 ! <DESCRIPTION>
2548 ! Given a time and some date decrement, computes a new time. Depending
2549 ! on the mapping algorithm from date to time, it may be possible to specify
2550 ! undefined decrements (i.e. if one decrements by 68 days and 3 months in
2551 ! a Julian calendar, it matters which order these operations are done and
2552 ! we don't want to deal with stuff like that, make it an error).
2553 ! </DESCRIPTION>
2554 ! <TEMPLATE>
2555 ! decrement_date(time, years, months, days, hours, minutes, seconds, ticks, err_msg))
2556 ! </TEMPLATE>
2557 ! <IN NAME="time" TYPE="time_type"> A time interval.</IN>
2558 ! <IN NAME="years" TYPE="integer">An decrement of years.</IN>
2559 ! <IN NAME="months" TYPE="integer">An decrement of months.</IN>
2560 ! <IN NAME="days" TYPE="integer">An decrement of days.</IN>
2561 ! <IN NAME="hours" TYPE="integer">An decrement of hours.</IN>
2562 ! <IN NAME="minutes" TYPE="integer">An decrement of minutes.</IN>
2563 ! <IN NAME="seconds" TYPE="integer">An decrement of seconds.</IN>
2564 ! <IN NAME="ticks" TYPE="integer">An decrement of ticks.</IN>
2565 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
2566 ! When present, and when non-blank, a fatal error condition as been detected.
2567 ! The string itself is an error message.
2568 ! It is recommended that, when err_msg is present in the call
2569 ! to this routine, the next line of code should be something
2570 ! similar to this:
2571 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
2572 ! </OUT>
2573 ! <OUT NAME="decrement_date" TYPE="time_type"> A new time based on the input
2574 ! time interval and the calendar type.
2575 ! </OUT>
2576 ! <IN NAME="allow_neg_inc" TYPE="logical, optional" DIM="(scalar)" DEFAULT=".true.">
2577 ! When .false., it is a fatal error if any of the input time increments are negative.
2578 ! This mimics the behavior of lima and earlier revisions.
2579 ! </IN>
2580 ! <NOTE>
2581 ! For all but the thirty_day_months calendar, decrements to months
2582 ! and years must be made separately from other units because of the
2583 ! non-associative nature of addition.
2584 ! If the result is a negative time (i.e. date before the base date)
2585 ! it is considered a fatal error.
2586 ! </NOTE>
2587 
2588  function decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
2590  type(time_type) :: decrement_date
2591  type(time_type), intent(in) :: time
2592  integer, intent(in), optional :: seconds, minutes, hours, days, months, years, ticks
2593  character(len=*), intent(out), optional :: err_msg
2594  logical, intent(in), optional :: allow_neg_inc
2595 
2596  integer :: oseconds, ominutes, ohours, odays, omonths, oyears, oticks
2597  character(len=128) :: err_msg_local
2598  logical :: allow_neg_inc_local
2599 
2600  if(present(err_msg)) err_msg = ''
2601 
2602  ! Missing optionals are set to 0
2603  oseconds = 0; if(present(seconds)) oseconds = seconds
2604  ominutes = 0; if(present(minutes)) ominutes = minutes
2605  ohours = 0; if(present(hours)) ohours = hours
2606  odays = 0; if(present(days)) odays = days
2607  omonths = 0; if(present(months)) omonths = months
2608  oyears = 0; if(present(years)) oyears = years
2609  oticks = 0; if(present(ticks)) oticks = ticks
2610  allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc
2611 
2612  if(.not.allow_neg_inc_local) then
2613  if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then
2614  write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks
2615  if(error_handler('function decrement_date', err_msg_local, err_msg)) return
2616  endif
2617  endif
2618  10 format('One or more time increments are negative: '// &
2619  'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6)
2620 
2621  if(.not.increment_date_private( &
2622  time, -oyears, -omonths, -odays, -ohours, -ominutes, -oseconds, -oticks, decrement_date, err_msg_local)) then
2623  if(error_handler('function decrement_date', err_msg_local, err_msg)) return
2624  endif
2625 
2626  end function decrement_date
2627  ! </FUNCTION>
2628 
2629 !=========================================================================
2630 ! START days_in_month BLOCK
2631 ! <FUNCTION NAME="days_in_month">
2632 
2633 ! <OVERVIEW>
2634 ! Given a time interval, gives the number of days in the
2635 ! month corresponding to the default calendar.
2636 ! </OVERVIEW>
2637 ! <DESCRIPTION>
2638 ! Given a time, computes the corresponding date given the selected
2639 ! date time mapping algorithm.
2640 ! </DESCRIPTION>
2641 ! <TEMPLATE> days_in_month(time) </TEMPLATE>
2642 
2643 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
2644 ! <OUT NAME="days_in_month" UNITS="" TYPE="integer" DIM="" DEFAULT="">
2645 ! The number of days in the month given the selected time
2646 ! mapping algorithm.
2647 ! </OUT>
2648 
2649 function days_in_month(Time, err_msg)
2651 ! Given a time, computes the corresponding date given the selected
2652 ! date time mapping algorithm
2653 
2654 integer :: days_in_month
2655 type(time_type), intent(in) :: time
2656 character(len=*), intent(out), optional :: err_msg
2657 
2659 if(present(err_msg)) err_msg = ''
2660 
2661 select case(calendar_type)
2662 case(thirty_day_months)
2664 case(gregorian)
2666 case(julian)
2668 case(noleap)
2670 case(no_calendar)
2671  if(error_handler('function days_in_month', &
2672  'days_in_month makes no sense when the calendar type is NO_CALENDAR', err_msg)) return
2673 case default
2674  if(error_handler('function days_in_month', 'Invalid calendar type', err_msg)) return
2675 end select
2676 end function days_in_month
2677 ! </FUNCTION>
2678 
2679 !--------------------------------------------------------------------------
2680 
2681 function days_in_month_gregorian(Time)
2683 ! Returns the number of days in a gregorian month.
2684 
2685 integer :: days_in_month_gregorian
2686 type(time_type), intent(in) :: time
2687 integer :: year, month, day, hour, minute, second, ticks
2688 
2689 call get_date_gregorian(time, year, month, day, hour, minute, second, ticks)
2691 if(leap_year_gregorian_int(year) .and. month == 2) days_in_month_gregorian = 29
2692 
2693 end function days_in_month_gregorian
2694 
2695 !--------------------------------------------------------------------------
2696 function days_in_month_julian(Time)
2698 ! Returns the number of days in a julian month.
2699 
2700 integer :: days_in_month_julian
2701 type(time_type), intent(in) :: time
2702 integer :: year, month, day, hour, minute, second, ticks
2703 
2704 call get_date_julian_private(time, year, month, day, hour, minute, second, ticks)
2706 if(leap_year_julian(time) .and. month == 2) days_in_month_julian = 29
2707 
2708 end function days_in_month_julian
2709 
2710 !--------------------------------------------------------------------------
2711 function days_in_month_thirty(Time)
2713 ! Returns the number of days in a thirty day month (needed for transparent
2714 ! changes to calendar type).
2715 
2716 integer :: days_in_month_thirty
2717 type(time_type), intent(in) :: time
2718 
2720 
2721 end function days_in_month_thirty
2722 
2723 !--------------------------------------------------------------------------
2724 function days_in_month_no_leap(Time)
2726 ! Returns the number of days in a 365 day year month.
2727 
2728 integer :: days_in_month_no_leap
2729 type(time_type), intent(in) :: time
2730 integer :: year, month, day, hour, minute, second, ticks
2731 
2732 call get_date_no_leap_private(time, year, month, day, hour, minute, second, ticks)
2734 
2735 end function days_in_month_no_leap
2736 
2737 ! END OF days_in_month BLOCK
2738 !==========================================================================
2739 ! START OF leap_year BLOCK
2740 ! <FUNCTION NAME="leap_year">
2741 
2742 ! <OVERVIEW>
2743 ! Returns true if the year corresponding to the input time is
2744 ! a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP.
2745 ! </OVERVIEW>
2746 ! <DESCRIPTION>
2747 ! Returns true if the year corresponding to the input time is
2748 ! a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP.
2749 ! </DESCRIPTION>
2750 ! <TEMPLATE> leap_year(time) </TEMPLATE>
2751 
2752 ! <IN NAME="time" UNITS="" TYPE="time_type" DIM="">A time interval.</IN>
2753 ! <OUT NAME="leap_year" UNITS="" TYPE="calendar_type" DIM="" DEFAULT="">
2754 ! true if the year corresponding to the input time is a leap year.
2755 ! </OUT>
2756 
2757 function leap_year(Time, err_msg)
2759 ! Is this date in a leap year for default calendar?
2760 
2761 logical :: leap_year
2762 type(time_type), intent(in) :: time
2763 character(len=*), intent(out), optional :: err_msg
2764 
2766 if(present(err_msg)) err_msg=''
2767 
2768 select case(calendar_type)
2769 case(thirty_day_months)
2770  leap_year = leap_year_thirty(time)
2771 case(gregorian)
2773 case(julian)
2774  leap_year = leap_year_julian(time)
2775 case(noleap)
2777 case default
2778  if(error_handler('function leap_year', 'Invalid calendar type in leap_year', err_msg)) return
2779 end select
2780 end function leap_year
2781 ! </FUNCTION>
2782 
2783 !--------------------------------------------------------------------------
2784 
2785 function leap_year_gregorian(Time)
2787 ! Is this a leap year for gregorian calendar?
2788 
2789 logical :: leap_year_gregorian
2790 type(time_type), intent(in) :: time
2791 integer :: seconds, minutes, hours, day, month, year
2792 
2793 call get_date(time, year, month, day, hours, minutes, seconds)
2795 
2796 end function leap_year_gregorian
2797 
2798 !--------------------------------------------------------------------------
2799 
2800 function leap_year_gregorian_int(year)
2802 integer, intent(in) :: year
2803 
2804 leap_year_gregorian_int = mod(year,4) == 0
2805 leap_year_gregorian_int = leap_year_gregorian_int .and. .not.mod(year,100) == 0
2806 leap_year_gregorian_int = leap_year_gregorian_int .or. mod(year,400) == 0
2807 
2808 end function leap_year_gregorian_int
2809 
2810 !--------------------------------------------------------------------------
2811 
2812 function leap_year_julian(Time)
2814 ! Returns the number of days in a julian month.
2815 
2816 logical :: leap_year_julian
2817 type(time_type), intent(in) :: time
2818 integer :: seconds, minutes, hours, day, month, year
2819 
2820 call get_date(time, year, month, day, hours, minutes, seconds)
2821 leap_year_julian = ((year / 4 * 4) == year)
2822 
2823 end function leap_year_julian
2824 
2825 !--------------------------------------------------------------------------
2826 
2827 function leap_year_thirty(Time)
2829 ! No leap years in thirty day months, included for transparency.
2830 
2831 logical :: leap_year_thirty
2832 type(time_type), intent(in) :: time
2833 
2834 leap_year_thirty = .false.
2835 
2836 end function leap_year_thirty
2837 
2838 !--------------------------------------------------------------------------
2839 
2840 function leap_year_no_leap(Time)
2842 ! Another tough one; no leap year returns false for leap year inquiry.
2843 
2844 logical :: leap_year_no_leap
2845 type(time_type), intent(in) :: time
2846 
2847 leap_year_no_leap = .false.
2848 
2849 end function leap_year_no_leap
2850 
2851 !END OF leap_year BLOCK
2852 !==========================================================================
2853 ! START OF length_of_year BLOCK
2854 ! <FUNCTION NAME="length_of_year">
2855 
2856 ! <OVERVIEW>
2857 ! Returns the mean length of the year in the default calendar setting.
2858 ! </OVERVIEW>
2859 ! <DESCRIPTION>
2860 ! There are no arguments in this function. It returns the mean
2861 ! length of the year in the default calendar setting.
2862 ! </DESCRIPTION>
2863 ! <TEMPLATE> length_of_year() </TEMPLATE>
2864 
2865 function length_of_year()
2867 ! What is the length of the year for the default calendar type
2868 
2869 type(time_type) :: length_of_year
2870 
2872 
2873 select case(calendar_type)
2874 case(thirty_day_months)
2876 case(gregorian)
2878 case(julian)
2880 case(noleap)
2882 case default
2883  call error_mesg('length_of_year','Invalid calendar type in length_of_year',fatal)
2884 end select
2885 end function length_of_year
2886 ! </FUNCTION>
2887 
2888 !--------------------------------------------------------------------------
2889 
2890 function length_of_year_thirty()
2893 
2895 
2896 end function length_of_year_thirty
2897 
2898 !---------------------------------------------------------------------------
2899 
2900 function length_of_year_gregorian()
2903 integer :: days, seconds
2904 
2905 days = days_in_400_year_period / 400
2906 seconds = 86400*(days_in_400_year_period/400. - days)
2907 length_of_year_gregorian = set_time(seconds, days)
2908 
2909 end function length_of_year_gregorian
2910 
2911 !--------------------------------------------------------------------------
2912 
2913 function length_of_year_julian()
2916 
2917 length_of_year_julian = set_time((24 / 4) * 60 * 60, 365)
2918 
2919 end function length_of_year_julian
2920 
2921 !--------------------------------------------------------------------------
2922 
2923 function length_of_year_no_leap()
2926 
2928 
2929 end function length_of_year_no_leap
2930 
2931 !--------------------------------------------------------------------------
2932 
2933 ! END OF length_of_year BLOCK
2934 !==========================================================================
2935 
2936 !==========================================================================
2937 ! return number of day in year; Jan 1st is day 1, not zero!
2938 function day_of_year(time)
2939  integer :: day_of_year
2940  type(time_type), intent(in) :: time
2941 
2942  integer :: second, minute, hour, day, month, year
2943  type(time_type) :: t
2944 
2945  call get_date(time,year,month,day,hour,minute,second)
2946  t = time-set_date(year,1,1,0,0,0)
2947  day_of_year = t%days + 1
2948 end
2949 
2950 ! START OF days_in_year BLOCK
2951 ! <FUNCTION NAME="days_in_year">
2952 
2953 ! <OVERVIEW>
2954 ! Returns the number of days in the calendar year corresponding to
2955 ! the date represented by time for the default calendar.
2956 ! </OVERVIEW>
2957 ! <DESCRIPTION>
2958 ! Returns the number of days in the calendar year corresponding to
2959 ! the date represented by time for the default calendar.
2960 ! </DESCRIPTION>
2961 ! <TEMPLATE> days_in_year(Time) </TEMPLATE>
2962 ! <IN NAME="Time" TYPE="time_type">A time interval.</IN>
2963 ! <OUT>
2964 ! The number of days in this year for the default calendar type.
2965 ! </OUT>
2966 
2967 
2968 function days_in_year(Time)
2970 ! What is the number of days in this year for the default calendar type
2971 
2972 integer :: days_in_year
2973 type(time_type), intent(in) :: time
2974 
2976 
2977 select case(calendar_type)
2978 case(thirty_day_months)
2980 case(gregorian)
2982 case(julian)
2984 case(noleap)
2986 case default
2987  call error_mesg('days_in_year','Invalid calendar type in days_in_year',fatal)
2988 end select
2989 end function days_in_year
2990 ! </FUNCTION>
2991 
2992 !--------------------------------------------------------------------------
2993 
2994 function days_in_year_thirty(Time)
2996 integer :: days_in_year_thirty
2997 type(time_type), intent(in) :: time
2998 
2999 days_in_year_thirty = 360
3000 
3001 end function days_in_year_thirty
3002 
3003 !---------------------------------------------------------------------------
3004 
3005 function days_in_year_gregorian(Time)
3007 integer :: days_in_year_gregorian
3008 type(time_type), intent(in) :: time
3009 
3010 if(leap_year_gregorian(time)) then
3012 else
3014 endif
3015 
3016 end function days_in_year_gregorian
3017 
3018 !--------------------------------------------------------------------------
3019 function days_in_year_julian(Time)
3021 integer :: days_in_year_julian
3022 type(time_type), intent(in) :: time
3023 
3024 if(leap_year_julian(time)) then
3025  days_in_year_julian = 366
3026 else
3027  days_in_year_julian = 365
3028 endif
3029 
3030 end function days_in_year_julian
3031 
3032 !--------------------------------------------------------------------------
3033 
3034 function days_in_year_no_leap(Time)
3036 integer :: days_in_year_no_leap
3037 type(time_type), intent(in) :: time
3038 
3040 
3041 end function days_in_year_no_leap
3042 
3043 !--------------------------------------------------------------------------
3044 
3045 ! END OF days_in_year BLOCK
3046 
3047 !==========================================================================
3048 ! <FUNCTION NAME="month_name">
3049 
3050 ! <OVERVIEW>
3051 ! Returns a character string containing the name of the
3052 ! month corresponding to month number n.
3053 ! </OVERVIEW>
3054 ! <DESCRIPTION>
3055 ! Returns a character string containing the name of the
3056 ! month corresponding to month number n. Definition is the
3057 ! same for all calendar types.
3058 ! </DESCRIPTION>
3059 ! <TEMPLATE> month_name(n) </TEMPLATE>
3060 ! <IN NAME="n" TYPE="integer">Month number.</IN>
3061 ! <OUT NAME="month_name" TYPE="character(len=9)">
3062 ! The character string associated with a month.
3063 ! All calendars have 12 months and return full
3064 ! month names, not abreviations.
3065 ! </OUT>
3066 
3067 function month_name(n)
3069 ! Returns character string associated with a month, for now, all calendars
3070 ! have 12 months and will return standard names.
3071 
3072 character (len=9) :: month_name
3073 integer, intent(in) :: n
3074 character (len = 9), dimension(12) :: months = (/'January ', 'February ', &
3075  'March ', 'April ', 'May ', 'June ', 'July ', &
3076  'August ', 'September', 'October ', 'November ', 'December '/)
3077 
3079 
3080 if(n < 1 .or. n > 12) call error_mesg('month_name','Illegal month index',fatal)
3081 
3082 month_name = months(n)
3083 
3084 end function month_name
3085 ! </FUNCTION>
3086 
3087 !==========================================================================
3088 
3089  function error_handler(routine, err_msg_local, err_msg)
3091 ! The purpose of this routine is to prevent the addition of an excessive amount of code in order to implement
3092 ! the error handling scheme involving an optional error flag of type character.
3093 ! It allows one line of code to accomplish what would otherwise require 6 lines.
3094 ! A value of .true. for this function is a flag to the caller that it should immediately return to it's caller.
3095 
3096  logical :: error_handler
3097  character(len=*), intent(in) :: routine, err_msg_local
3098  character(len=*), intent(out), optional :: err_msg
3099 
3100  error_handler = .false.
3101  if(present(err_msg)) then
3102  err_msg = err_msg_local
3103  error_handler = .true.
3104  else
3105  call error_mesg(trim(routine),trim(err_msg_local),fatal)
3106  endif
3107 
3108  end function error_handler
3109 
3110 !==========================================================================
3111 !------------------------------------------------------------------------
3112 ! <SUBROUTINE NAME="time_manager_init">
3113 
3114 ! <OVERVIEW>
3115 ! Writes the version information to the log file
3116 ! </OVERVIEW>
3117 ! <DESCRIPTION>
3118 ! Initialization routine.
3119 ! Writes the version information to the log file
3120 ! </DESCRIPTION>
3121 ! <TEMPLATE>time_manager_init()</TEMPLATE>
3122 
3123 subroutine time_manager_init ( )
3125  if (module_is_initialized) return ! silent return if already called
3126 
3127  call write_version_number("TIME_MANAGER_MOD", version)
3128  module_is_initialized = .true.
3129 
3130 end subroutine time_manager_init
3131 ! </SUBROUTINE>
3132 
3133 !------------------------------------------------------------------------
3134 ! <SUBROUTINE NAME="print_time">
3135 
3136 ! <OVERVIEW>
3137 ! Prints the given time_type argument as a time (using days, seconds and ticks)
3138 ! </OVERVIEW>
3139 ! <DESCRIPTION>
3140 ! Prints the given time_type argument as a time (using days, seconds and ticks)
3141 ! NOTE: there is no check for PE number.
3142 ! </DESCRIPTION>
3143 ! <TEMPLATE>print_time (time,str,unit)</TEMPLATE>
3144 ! <IN NAME="time" TYPE="time_type"> Time that will be printed. </IN>
3145 ! <IN NAME="str" TYPE="character (len=*)" DEFAULT="TIME: or DATE:">
3146 ! Character string that precedes the printed time or date.
3147 ! </IN>
3148 ! <IN NAME="unit" TYPE="integer">
3149 ! Unit number for printed output. The default unit is stdout.
3150 ! </IN>
3151 subroutine print_time (Time,str,unit)
3152 type(time_type) , intent(in) :: time
3153 character (len=*), intent(in), optional :: str
3154 integer , intent(in), optional :: unit
3155 integer :: s,d,ticks, ns,nd,nt, unit_in
3156 character(len=19) :: fmt
3157 
3158 ! prints the time to standard output (or optional unit) as days and seconds
3159 ! NOTE: there is no check for PE number
3160 
3161  unit_in = stdout()
3162  if (present(unit)) unit_in = unit
3163 
3164  call get_time (time,s,d,ticks)
3165 
3166 ! format output
3167 ! get number of digits for days and seconds strings
3168  nd = int(log10(real(max(1,d))))+1
3169  ns = int(log10(real(max(1,s))))+1
3170  nt = int(log10(real(max(1,ticks))))+1
3171  write (fmt,10) nd, ns, nt
3172 10 format ('(a,i',i2.2,',a,i',i2.2,',a,i',i2.2,')')
3173 
3174  if (present(str)) then
3175  write (unit_in,fmt) trim(str)//' day=', d, ', sec=', s, ', ticks=', ticks
3176  else
3177  write (unit_in,fmt) 'TIME: day=', d, ', sec=', s, ', ticks=', ticks
3178  endif
3179 
3180 end subroutine print_time
3181 ! </SUBROUTINE>
3182 
3183 !------------------------------------------------------------------------
3184 ! <SUBROUTINE NAME="print_date">
3185 
3186 ! <OVERVIEW>
3187 ! prints the time to standard output (or optional unit) as a date.
3188 ! </OVERVIEW>
3189 ! <DESCRIPTION>
3190 ! Prints the given time_type argument as a date (using year, month, day,
3191 ! hour, minutes, seconds and ticks). NOTE: there is no check for PE number.
3192 ! </DESCRIPTION>
3193 ! <TEMPLATE> print_date (time,str,unit)
3194 ! </TEMPLATE>
3195 ! <IN NAME="time" TYPE="time_type"> Time that will be printed. </IN>
3196 ! <IN NAME="str" TYPE="character (len=*)" DEFAULT="TIME: or DATE:">
3197 ! Character string that precedes the printed time or date.
3198 ! </IN>
3199 ! <IN NAME="unit" TYPE="integer">
3200 ! Unit number for printed output. The default unit is stdout.
3201 ! </IN>
3202 
3203 subroutine print_date (Time,str,unit)
3204 type(time_type) , intent(in) :: time
3205 character (len=*), intent(in), optional :: str
3206 integer , intent(in), optional :: unit
3207 integer :: y,mo,d,h,m,s, unit_in
3208 character(len=9) :: mon
3209 
3210 ! prints the time to standard output (or optional unit) as a date
3211 ! NOTE: there is no check for PE number
3212 
3213  unit_in = stdout()
3214  if (present(unit)) unit_in = unit
3215 
3216  call get_date (time,y,mo,d,h,m,s)
3217  mon = month_name(mo)
3218  if (present(str)) then
3219  write (unit_in,10) trim(str)//' ', y,mon(1:3),' ',d,' ',h,':',m,':',s
3220  else
3221  write (unit_in,10) 'DATE: ', y,mon(1:3),' ',d,' ',h,':',m,':',s
3222  endif
3223 10 format (a,i4,1x,a3,4(a1,i2.2))
3224 
3225 end subroutine print_date
3226 ! </SUBROUTINE>
3227 
3228 !------------------------------------------------------------------------
3229 ! <FUNCTION NAME="valid_calendar_types">
3230 
3231 ! <OVERVIEW>
3232 ! Returns a character string that describes the
3233 ! calendar type corresponding to the input integer.
3234 ! </OVERVIEW>
3235 ! <DESCRIPTION>
3236 ! Returns a character string that describes the
3237 ! calendar type corresponding to the input integer.
3238 ! </DESCRIPTION>
3239 ! <IN NAME="ncal" TYPE="integer">
3240 ! An integer corresponding to a valid calendar type.
3241 ! </IN>
3242 ! <OUT NAME="err_msg" TYPE="character, optional" DIM="(scalar)">
3243 ! When present, and when non-blank, a fatal error condition as been detected.
3244 ! The string itself is an error message.
3245 ! It is recommended that, when err_msg is present in the call
3246 ! to this routine, the next line of code should be something
3247 ! similar to this:
3248 ! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL)
3249 ! </OUT>
3250 ! <OUT NAME="valid_calendar_types" TYPE="character(len=24)">
3251 ! A character string describing the calendar type.
3252 ! </OUT>
3253 
3254 function valid_calendar_types(ncal, err_msg)
3255 integer, intent(in) :: ncal
3256 character(len=*), intent(out), optional :: err_msg
3257 character(len=24) :: valid_calendar_types
3258 character(len=128) :: err_msg_local
3259 
3261 
3262 if(present(err_msg)) err_msg = ''
3263 
3264 if(ncal == no_calendar) then
3265  valid_calendar_types = 'NO_CALENDAR '
3266 else if(ncal == thirty_day_months) then
3267  valid_calendar_types = 'THIRTY_DAY_MONTHS '
3268 else if(ncal == julian) then
3269  valid_calendar_types = 'JULIAN '
3270 else if(ncal == gregorian) then
3271  valid_calendar_types = 'GREGORIAN '
3272 else if(ncal == noleap) then
3273  valid_calendar_types = 'NOLEAP '
3274 else
3275  write(err_msg_local,'(a,i4,a)') 'calendar type=',ncal,' is invalid.'
3276  if(error_handler('function valid_calendar_types', err_msg_local, err_msg)) return
3277 endif
3278 end function valid_calendar_types
3279 ! </FUNCTION>
3280 !------------------------------------------------------------------------
3281 
3282 !--- get the a character string that represents the time. The format will be
3283 !--- yyyymmdd.hhmmss
3284 function date_to_string(time, err_msg)
3285  type(time_type), intent(in) :: time
3286  character(len=*), intent(out), optional :: err_msg
3287  character(len=128) :: err_msg_local
3288  character(len=15) :: date_to_string
3289  integer :: yr,mon,day,hr,min,sec
3290 
3291  if(present(err_msg)) err_msg = ''
3292  call get_date(time,yr,mon,day,hr,min,sec)
3293  if (yr <= 9999) then
3294  write(date_to_string,'(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec
3295  else
3296  write(err_msg_local, '(a,i4.4,a)') 'year = ', yr, ' should be less than 10000'
3297  if(error_handler('function date_to_string', err_msg_local, err_msg)) return
3298  endif
3299 
3300 end function date_to_string
3301 
3302 !> \author Tom Robinson
3303 !! \email thomas.robinson@noaa.gov
3304 !! \brief This routine converts the integer t%days to a string
3305 subroutine time_list_error (T,Terr)
3306  type(time_type), intent(in) :: t !< time_type input
3307  character(len=:), allocatable :: terr !< String holding the t%days
3308 !> Allocate the string
3309  allocate (character(len=10) :: terr)
3310 !> Write the integer to the string
3311  write (terr,'(I0)') t%days
3312 end subroutine time_list_error
3313 
3314 
3315 end module time_manager_mod
3316 
3317 ! <INFO>
3318 
3319 ! <TESTPROGRAM NAME="time_main2">
3320 ! <PRE>
3321 ! use time_manager_mod
3322 ! implicit none
3323 ! type(time_type) :: dt, init_date, astro_base_date, time, final_date
3324 ! type(time_type) :: next_rad_time, mid_date
3325 ! type(time_type) :: repeat_alarm_freq, repeat_alarm_length
3326 ! integer :: num_steps, i, days, months, years, seconds, minutes, hours
3327 ! integer :: months2, length
3328 ! real :: astro_days
3329 !
3330 ! !Set calendar type
3331 ! ! call set_calendar_type(THIRTY_DAY_MONTHS)
3332 ! call set_calendar_type(JULIAN)
3333 ! ! call set_calendar_type(NOLEAP)
3334 !
3335 ! ! Set timestep
3336 ! dt = set_time(1100, 0)
3337 !
3338 ! ! Set initial date
3339 ! init_date = set_date(1992, 1, 1)
3340 !
3341 ! ! Set date for astronomy delta calculation
3342 ! astro_base_date = set_date(1970, 1, 1, 12, 0, 0)
3343 !
3344 ! ! Copy initial time to model current time
3345 ! time = init_date
3346 !
3347 ! ! Determine how many steps to do to run one year
3348 ! final_date = increment_date(init_date, years = 1)
3349 ! num_steps = (final_date - init_date) / dt
3350 ! write(*, *) 'Number of steps is' , num_steps
3351 !
3352 ! ! Want to compute radiation at initial step, then every two hours
3353 ! next_rad_time = time + set_time(7200, 0)
3354 !
3355 ! ! Test repeat alarm
3356 ! repeat_alarm_freq = set_time(0, 1)
3357 ! repeat_alarm_length = set_time(7200, 0)
3358 !
3359 ! ! Loop through a year
3360 ! do i = 1, num_steps
3361 !
3362 ! ! Increment time
3363 ! time = time + dt
3364 !
3365 ! ! Test repeat alarm
3366 ! if(repeat_alarm(time, repeat_alarm_freq, repeat_alarm_length)) &
3367 ! write(*, *) 'REPEAT ALARM IS TRUE'
3368 !
3369 ! ! Should radiation be computed? Three possible tests.
3370 ! ! First test assumes exact interval; just ask if times are equal
3371 ! ! if(time == next_rad_time) then
3372 ! ! Second test computes rad on last time step that is <= radiation time
3373 ! ! if((next_rad_time - time) < dt .and. time < next_rad) then
3374 ! ! Third test computes rad on time step closest to radiation time
3375 ! if(interval_alarm(time, dt, next_rad_time, set_time(7200, 0))) then
3376 ! call get_date(time, years, months, days, hours, minutes, seconds)
3377 ! write(*, *) days, month_name(months), years, hours, minutes, seconds
3378 !
3379 ! ! Need to compute real number of days between current time and astro_base
3380 ! call get_time(time - astro_base_date, seconds, days)
3381 ! astro_days = days + seconds / 86400.
3382 ! ! write(*, *) 'astro offset ', astro_days
3383 ! end if
3384 !
3385 ! ! Can compute daily, monthly, yearly, hourly, etc. diagnostics as for rad
3386 !
3387 ! ! Example: do diagnostics on last time step of this month
3388 ! call get_date(time + dt, years, months2, days, hours, minutes, seconds)
3389 ! call get_date(time, years, months, days, hours, minutes, seconds)
3390 ! if(months /= months2) then
3391 ! write(*, *) 'last timestep of month'
3392 ! write(*, *) days, months, years, hours, minutes, seconds
3393 ! endif
3394 !
3395 ! ! Example: mid-month diagnostics; inefficient to make things clear
3396 ! length = days_in_month(time)
3397 ! call get_date(time, years, months, days, hours, minutes, seconds)
3398 ! mid_date = set_date(years, months, 1) + set_time(0, length) / 2
3399 !
3400 ! if(time < mid_date .and. (mid_date - time) < dt) then
3401 ! write(*, *) 'mid-month time'
3402 ! write(*, *) days, months, years, hours, minutes, seconds
3403 ! endif
3404 !
3405 ! end do
3406 !
3407 ! </PRE>
3408 ! end program time_main2
3409 
3410 ! </TESTPROGRAM>
3411 ! <NOTE>
3412 ! The <a name="base date">base date</a> is implicitly defined so users don't
3413 ! need to be concerned with it. For the curious, the base date is defined as
3414 ! 0 seconds, 0 minutes, 0 hours, day 1, month 1, year 1
3415 ! </NOTE>
3416 ! <NOTE>
3417 ! Please note that a time is a positive definite quantity.
3418 ! </NOTE>
3419 ! <NOTE>
3420 ! See the <LINK SRC="TEST PROGRAM">Test Program </LINK> for a simple program
3421 ! that shows some of the capabilities of the time manager.
3422 ! </NOTE>
3423 ! </INFO>
3424 
3425 #ifdef test_time_manager
3426  program test
3427  use mpp_mod, only: input_nml_file
3428  use fms_mod, only: fms_init, fms_end, stderr
3429  use fms_mod, only: open_namelist_file, check_nml_error, close_file, open_file
3430  use constants_mod, only: constants_init, rseconds_per_day=>seconds_per_day
3431  use fms_io_mod, only: fms_io_exit
3437  use time_manager_mod, only: operator(-), operator(+), operator(*), operator(/), &
3438  operator(>), operator(>=), operator(==), operator(/=), &
3439  operator(<), operator(<=), operator(//), assignment(=)
3440 
3441  implicit none
3442 
3443  type(time_type) :: time, time1, time2
3444  real :: xx
3445  integer :: yr, mo, day, hr, min, sec, ticks
3446  integer :: year, month, dday, days_this_month
3447  integer :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/)
3448  logical :: leap
3449  integer :: nr, icode, nmlunit, ierr, io, nn, errunit, outunit
3450  character(len=256) :: err_msg, char_date
3451  character(len=8), allocatable, dimension(:) :: test_time
3452  character(len=23), allocatable, dimension(:) :: test_date
3453  character(len=8) :: test_name
3454 
3455 logical :: test1 =.true.,test2 =.true.,test3 =.true.,test4 =.true.,test5 =.true.,test6 =.true.,test7 =.true.,test8 =.true.
3456 logical :: test9 =.true.,test10=.true.,test11=.true.,test12=.true.,test13=.true.,test14=.true.,test15=.true.,test16=.true.
3457 logical :: test17=.true.,test18=.true.,test19=.true.
3458 
3459  namelist / test_nml / test1 ,test2 ,test3 ,test4 ,test5 ,test6 ,test7 ,test8, &
3460  test9 ,test10,test11,test12,test13,test14,test15,test16, &
3461  test17,test18,test19
3462 
3463  call fms_init
3464  call constants_init
3465 
3466 #ifdef INTERNAL_FILE_NML
3467  read (input_nml_file, test_nml, iostat=io)
3468  ierr = check_nml_error(io, 'test_nml')
3469 #else
3470  nmlunit = open_namelist_file()
3471  ierr=1
3472  do while (ierr /= 0)
3473  read(nmlunit, nml=test_nml, iostat=io, end=12)
3474  ierr = check_nml_error(io, 'test_nml')
3475  enddo
3476  12 call close_file (nmlunit)
3477 #endif
3478 
3479  outunit = open_file(file='test_time_manager.out', form='formatted', action='write')
3480  errunit = stderr()
3481  call set_ticks_per_second(10)
3482 
3483  !==============================================================================================
3484  ! Tests of set_time_i and get_time without ticks
3485 
3486  if(test1) then
3487  write(outunit,'(/,a)') '################################# test1 #################################'
3488  time = set_time(seconds=2, days=1)
3489  call get_time(time, sec, day, ticks)
3490  write(outunit,'(a,i2,a,i8,a,i2)') ' test1.1: days=',day,' seconds=',sec,' ticks=',ticks
3491  call get_time(time, sec, day)
3492  write(outunit,'(a,i2,a,i8)') ' test1.2: days=',day,' seconds=',sec
3493  call get_time(time, sec)
3494  write(outunit,'(a,i8)') ' test1.2: seconds=',sec
3495  endif
3496  !==============================================================================================
3497  ! Tests of set_time_i and get_time with ticks
3498 
3499  if(test2) then
3500  write(outunit,'(/,a)') '################################# test2 #################################'
3501  time = set_time(seconds=2, days=1, ticks=5)
3502  call get_time(time, sec, day, ticks)
3503  write(outunit,'(a,i2,a,i6,a,i2)') ' test2.1: days=',day,' seconds=',sec,' ticks=',ticks
3504  call get_time(time, sec, ticks=ticks)
3505  write(outunit,'(a,i6,a,i2)') ' test2.2: seconds=',sec,' ticks=',ticks
3506  call get_time(time, sec, day, err_msg=err_msg)
3507  if(err_msg /= '') then
3508  write(outunit,'(a)') ' test2.3 successful: '//trim(err_msg)
3509  else
3510  write(outunit,'(a,i2,a,i8)') ' test2.3 fails. days=',day,' seconds=',sec
3511  endif
3512  call get_time(time, sec, err_msg=err_msg)
3513  if(err_msg /= '') then
3514  write(outunit,'(a)') ' test2.4 successful: '//trim(err_msg)
3515  else
3516  write(outunit,'(a,i8)') ' test2.4 fails. seconds=',sec
3517  endif
3518  endif
3519  !==============================================================================================
3520  ! Tests of time operators
3521  ! Test of function scalar_time_mult is not necessary, it simply calls time_scalar_mult.
3522  ! Test of function time_ne is not necessary, it simply calls time_eq.
3523  ! Test of function time_ge is not necessary, it simply calls time_gt.
3524  ! Test of function time_le is not necessary, it simply calls time_lt and time_eq.
3525  ! Test of function time_ne is not necessary, it simply calls time_eq.
3526 
3527  if(test3) then
3528  write(outunit,'(/,a)') '################################# test3 #################################'
3529  ! Test of function time_plus
3530  call print_time(set_time(seconds=0, days=2, ticks=5) + set_time(seconds=0, days=2, ticks=6), 'test3.1:', unit=outunit)
3531 
3532  ! Test of function time_minus
3533  ! The minus operator for time ensures a positive result. In effect is does this: abs(time1-time2)
3534  call print_time(set_time(seconds=0, days=2, ticks=5) - set_time(seconds=0, days=2, ticks=6), 'test3.2:', unit=outunit)
3535 
3536  ! Test of function time_scalar_mult. Note that 25000*86399 is greater than huge = 2**31 - 1
3537  call print_time(2*set_time(seconds=0, days=2, ticks=6), 'test3.3:', unit=outunit)
3538  call print_time(25000*set_time(seconds=86399, days=0, ticks=0), 'test3.4:', unit=outunit)
3539 
3540  ! Test of function time_scalar_divide
3541  call print_time(set_time(seconds=0, days=60000, ticks=2)/2, 'test3.5:', unit=outunit)
3542 
3543  ! Test of function time_real_divide
3544  xx = set_time(seconds=0, days=60000, ticks=2)//set_time(seconds=86400)
3545  write(outunit,'("test3.6: xx=",f15.9)') xx
3546 
3547  ! Test of function time_divide
3548  nn = set_time(seconds=0, days=60000, ticks=2)//set_time(seconds=86400)
3549  write(outunit,'("test3.7: nn=",i6)') nn
3550 
3551  ! Test of function time_gt
3552  if(set_time(seconds=1, days=1, ticks=2) > set_time(seconds=1, days=1, ticks=1)) then
3553  write(outunit,'("test3.8 successful")')
3554  else
3555  write(outunit,'("test3.8 fails")')
3556  endif
3557  if(set_time(seconds=1, days=1, ticks=2) > set_time(seconds=1, days=1, ticks=2)) then
3558  write(outunit,'("test3.9 fails")')
3559  else
3560  write(outunit,'("test3.9 successful")')
3561  endif
3562 
3563  ! Test of function time_lt
3564  if(set_time(seconds=1, days=1, ticks=1) < set_time(seconds=1, days=1, ticks=2)) then
3565  write(outunit,'("test3.10 successful")')
3566  else
3567  write(outunit,'("test3.10 fails")')
3568  endif
3569  if(set_time(seconds=1, days=1, ticks=2) < set_time(seconds=1, days=1, ticks=2)) then
3570  write(outunit,'("test3.11 fails")')
3571  else
3572  write(outunit,'("test3.11 successful")')
3573  endif
3574 
3575  ! Test of function time_eq
3576  if(set_time(seconds=1, days=1, ticks=1) == set_time(seconds=1, days=1, ticks=1)) then
3577  write(outunit,'("test3.12 successful")')
3578  else
3579  write(outunit,'("test3.12 fails")')
3580  endif
3581  if(set_time(seconds=1, days=1, ticks=1) == set_time(seconds=1, days=1, ticks=2)) then
3582  write(outunit,'("test3.13 fails")')
3583  else
3584  write(outunit,'("test3.13 successful")')
3585  endif
3586  endif
3587  !==============================================================================================
3588  ! Tests of set_time_c
3589 
3590  if(test4) then
3591  write(outunit,'(/,a)') '################################# test4 #################################'
3592  test_name = 'test4. '
3593  allocate(test_time(15))
3594  test_time( 1: 6) = (/'1 10 ','1 10. ','1 10.000','1 0.0 ','1 .000','1 . '/)
3595  test_time( 7: 9) = (/'1 10.20 ','1 10.300','1 0.40 '/)
3596  test_time(10:15) = (/'1 .510','2 .50001','1.0 10.2','10.30000','10-0.40 ','10:1.510'/) ! invalid forms
3597  do nr=1,9
3598  write(test_name(7:8),'(i2.2)') nr
3599  time = set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
3600  if(err_msg == '') then
3601  call print_time(time, test_name//':', unit=outunit)
3602  else
3603  write(outunit,'(a)') test_name//' fails: '//trim(err_msg)
3604  endif
3605  enddo
3606 
3607  test_time(1:6) = (/'1 .510','2 .50001','1.0 10.2','10.30000','10-0.40 ','10:1.510'/)
3608  do nr=10,15
3609  write(test_name(7:8),'(i2.2)') nr
3610  time = set_time(trim(test_time(nr)), err_msg=err_msg, allow_rounding=.false.)
3611  if(err_msg /= '') then
3612  write(outunit,'(a)') test_name//' successful: '//trim(err_msg)
3613  else
3614  write(outunit,'(a)') test_name//' fails '
3615  endif
3616  enddo
3617  endif
3618 
3619  !==============================================================================================
3620  ! Tests of set_date_i
3621 
3622  if(test5) then
3623  write(outunit,'(/,a)') '################################# test5 #################################'
3625  call print_time(set_date(1980, 1, 1, 0, 0, 0),' test5.1:', unit=outunit)
3626  call print_time(set_date(1980, 1, 2, 3, 4, 5, 6),' test5.2:', unit=outunit)
3627  call print_time(set_date(1980, 1, 2, tick=6),' test5.3:', unit=outunit)
3628  time = set_date(1980, 1, 2, tick=10, err_msg=err_msg)
3629  if(err_msg == '') then
3630  write(outunit,'(a)') ' test5.4 fails'
3631  else
3632  write(outunit,'(a)') ' test5.4 successful: '//trim(err_msg)
3633  endif
3634  endif
3635  !==============================================================================================
3636  ! Tests of set_date_c
3637 
3638  if(test6) then
3639  write(outunit,'(/,a)') '################################# test6 #################################'
3640  test_name = 'test6. '
3642  allocate(test_date(6))
3643  test_date(1:3) = (/' 1980-12-30 01:01:11 ',' 1980-12-30 01:01:11.50',' 1980-12-30 01:01:11.55'/)
3644  test_date(4:6) = (/' 1980-12-30 01:01:11.96',' 1980-1-3 1:1:11 ',' 1980-1-3 1:1:11.99 '/)
3645  do nr=1,6
3646  write(test_name(7:8),'(i2.2)') nr
3647  time = set_date(trim(test_date(nr)), err_msg=err_msg, allow_rounding=.true., zero_year_warning=.true.)
3648  if(err_msg == '') then
3649  call print_time(time,test_name//' successful:', unit=outunit)
3650  else
3651  write(outunit,'(a)') test_name//'fails: '//trim(err_msg)
3652  endif
3653  enddo
3655  call print_time(set_date('1900-02-30 00:00:00'),'test6.7:', unit=outunit)
3656  time = set_date('1900-01-31 00:00:00', err_msg=err_msg)
3657  if(err_msg == '') then
3658  write(outunit,'(a)') 'test6.8 fails'
3659  else
3660  write(outunit,'(a)') 'test6.8 successful '//trim(err_msg)
3661  endif
3663  time = set_date('1901-02-29 00:00:00', err_msg=err_msg)
3664  if(err_msg == '') then
3665  write(outunit,'(a)') 'test6.9 fails'
3666  else
3667  write(outunit,'(a)') 'test6.9 successful '//trim(err_msg)
3668  endif
3669  endif
3670 !==============================================================================================
3671 ! Tests of decrement_date and increment_date
3672 
3673  if(test7) then
3674  write(outunit,'(/,a)') '################################# test7 #################################'
3675  char_date = '1904-01-01 00:00:00'
3676  write(outunit,'(a)') ' Initial date='//trim(char_date)//':00'
3677 
3678  do nr=1,4
3679  write(outunit,'("=================================================================")')
3680  if(nr == 1) then
3682  write(outunit,'(" THIRTY_DAY_MONTHS")')
3683  endif
3684  if(nr == 2) then
3686  write(outunit,'(" NOLEAP")')
3687  endif
3688  if(nr == 3) then
3690  write(outunit,'(" JULIAN")')
3691  endif
3692  if(nr == 4) then
3694  write(outunit,'(" GREGORIAN")')
3695  endif
3696  time1 = set_date(trim(char_date))
3697  do year=-1,1
3698  do month=-1,1
3699  write(outunit,'(" test of decrement_date increments: year=",i2," month=",i2)') year,month
3700  time2 = decrement_date(time1, year, month, err_msg=err_msg)
3701  if(err_msg /= '') then
3702  write(outunit,'(a)') 'test of decrement_date fails '//trim(err_msg)
3703  else
3704  call get_date(time2, yr, mo, day, hr, min, sec, ticks)
3705  write(outunit,20) yr, mo, day, hr, min, sec, ticks
3706  endif
3707  enddo
3708  enddo
3709  time1 = set_date(1, 1, 2, 1, 1, 1, 1, err_msg)
3710  write(outunit,'(" Initial date = 01-01-02 01:01:01:01")')
3711  do icode=0,242
3712  day = modulo(icode/81,3) - 1
3713  hr = modulo(icode/27,3) - 1
3714  min = modulo(icode/9, 3) - 1
3715  sec = modulo(icode/3, 3) - 1
3716  ticks = modulo(icode ,3) - 1
3717  write(outunit,11) day, hr, min, sec, ticks
3718  time2 = increment_date(time1, 0, 0, day, hr, min, sec, ticks, err_msg)
3719  call get_date(time2, yr, mo, day, hr, min, sec, ticks)
3720  write(outunit,20) yr, mo, day, hr, min, sec, ticks
3721  enddo
3722  enddo
3723  endif
3724 
3725  11 format(' test of increment_date increments: day=',i2,' hr=',i2,' min=',i2,' sec=',i2,' ticks=',i2)
3726  20 format(' time=',i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2, ':', i2.2)
3727  !==============================================================================================
3728  ! Tests involving Feb 29
3729 
3730  if(test8) then
3731  write(outunit,'(/,a)') '################################# test8 #################################'
3733  time = set_date('1904-02-29 00:00:00', err_msg=err_msg)
3734  if(err_msg == '') then
3735  call print_time(time, 'test8.1 successful', unit=outunit)
3736  else
3737  write(outunit,'(a)') 'test8.1 fails: '//trim(err_msg)
3738  endif
3739 
3741  time = set_date('1904-02-29 00:00:00', err_msg=err_msg)
3742  if(err_msg == '') then
3743  write(outunit,'(a)') 'test8.2 fails'
3744  else
3745  write(outunit,'(a)') 'test8.2 successful: '//trim(err_msg)
3746  endif
3747 
3749  time = set_date('1900-02-29 00:00:00', err_msg=err_msg)
3750  if(err_msg == '') then
3751  write(outunit,'(a)') 'test8.3 fails'
3752  else
3753  write(outunit,'(a)') 'test8.3 successful: '//trim(err_msg)
3754  endif
3755  time = set_date('2000-02-29 00:00:00', err_msg=err_msg)
3756  if(err_msg == '') then
3757  write(outunit,'(a)') 'test8.4 successful'
3758  else
3759  write(outunit,'(a)') 'test8.4 fails: '//trim(err_msg)
3760  endif
3761 
3763  time = set_date('1900-02-29 00:00:00', err_msg=err_msg)
3764  if(err_msg == '') then
3765  write(outunit,'(a)') 'test8.5 successful'
3766  else
3767  write(outunit,'(a)') 'test8.5 fails: '//trim(err_msg)
3768  endif
3769  time = set_date('1901-02-29 00:00:00', err_msg=err_msg)
3770  if(err_msg == '') then
3771  write(outunit,'(a)') 'test8.6 fails'
3772  else
3773  write(outunit,'(a)') 'test8.6 successful: '//trim(err_msg)
3774  endif
3775  endif
3776  !==============================================================================================
3777  ! Tests of days_in_month
3778 
3779  if(test9) then
3780  write(outunit,'(/,a)') '################################# test9 #################################'
3781  day = days_in_month(set_date('1901-02-28 00:00:00'))
3782  write(outunit,'(a,i4)') ' test9.1: day=',day
3783  day = days_in_month(set_date('1901-07-01 00:00:00'))
3784  write(outunit,'(a,i4)') ' test9.2: day=',day
3785  endif
3786  !==============================================================================================
3787  ! Tests of get_time error flag
3788 
3789  if(test10) then
3790  write(outunit,'(/,a)') '################################# test10 #################################'
3791  time = set_time(seconds=2, days=1, ticks=1)
3792  call get_time(time, seconds=sec, days=day, err_msg=err_msg)
3793  if(err_msg == '') then
3794  write(outunit,'(a)') 'test10.1 fails'
3795  else
3796  write(outunit,'(a)') 'test10.1 successful: '//trim(err_msg)
3797  endif
3799  time = set_time(seconds=2, days=1, ticks=1)
3800  call get_date(time, yr, mo, day, hr, min, sec, err_msg=err_msg)
3801  if(err_msg == '') then
3802  write(outunit,'(a)') 'test10.2 fails'
3803  else
3804  write(outunit,'(a)') 'test10.2 successful: '//trim(err_msg)
3805  endif
3806  endif
3807  !==============================================================================================
3808  ! Tests of increment_time and decrement_time
3809 
3810  if(test11) then
3811  write(outunit,'(/,a)') '################################# test11 #################################'
3812  call print_time(increment_time(set_time(seconds=0, days=2), seconds=0, days=1),'test11.1:', unit=outunit)
3813  call print_time(decrement_time(set_time(seconds=0, days=2), seconds=0, days=1),'test11.2:', unit=outunit)
3814  call print_time(increment_time(set_time(seconds=0, days=2, ticks=5), seconds=400, days=1, ticks=14),'test11.3:', unit=outunit)
3815  call print_time(decrement_time(set_time(seconds=0, days=2, ticks=5), seconds=400, days=1, ticks=14),'test11.4:', unit=outunit)
3816  endif
3817  !==============================================================================================
3818  ! Tests of negative increments in increment_time and decrement_time
3819 
3820  if(test12) then
3821  write(outunit,'(/,a)') '################################# test12 #################################'
3822  call print_time(increment_time(set_time(seconds=0, days=2), seconds=0, days=-1),'test12.1:', unit=outunit)
3823  call print_time(decrement_time(set_time(seconds=0, days=2), seconds=0, days=-1),'test12.2:', unit=outunit)
3824  call print_time(increment_time(set_time(seconds=0, days=2, ticks=5),seconds=-400,days=-1,ticks=-14),'test12.3:',unit=outunit)
3825  call print_time(decrement_time(set_time(seconds=0, days=2, ticks=5),seconds=-400,days=-1,ticks=-14),'test12.4:',unit=outunit)
3826  endif
3827  !==============================================================================================
3828  ! Test of trap for negative time
3829 
3830  if(test13) then
3831  write(outunit,'(/,a)') '################################# test13 #################################'
3832  time = set_time(seconds= 2, days=0, ticks=-21, err_msg=err_msg)
3833  if(err_msg == '') then
3834  write(outunit,'(a)') 'test13.1 fails'
3835  else
3836  write(outunit,'(a)') 'test13.1 successful: '//trim(err_msg)
3837  endif
3838  endif
3839  !==============================================================================================
3840  ! Tests of negative seconds and/or ticks
3841 
3842  if(test14) then
3843  write(outunit,'(/,a)') '################################# test14 #################################'
3844  call print_time(set_time(seconds=-86399, days=2, ticks=-10),'test14.1:', unit=outunit)
3845  call print_time(set_time(seconds=-86390, days=2, ticks=-95),'test14.2:', unit=outunit)
3846  call print_time(set_time(seconds= 86400, days=2, ticks= 95),'test14.3:', unit=outunit)
3847  endif
3848  !==============================================================================================
3849  ! Tests of consistency of day numbering between calendars
3850 
3851  if(test15) then
3852  write(outunit,'(/,a)') '################################# test15 #################################'
3854  time = set_date(1, 1, 1)
3855  call get_time(time, sec, day)
3856  write(outunit,10) 'GREGORIAN',day
3857 
3859  time = set_date(1, 1, 1)
3860  call get_time(time, sec, day)
3861  write(outunit,10) 'JULIAN',day
3862 
3864  time = set_date(1, 1, 1)
3865  call get_time(time, sec, day)
3866  write(outunit,10) 'THIRTY_DAY_MONTHS',day
3867 
3869  time = set_date(1, 1, 1)
3870  call get_time(time, sec, day)
3871  write(outunit,10) 'NOLEAP',day
3872  endif
3873 
3874  10 format(a17,' Jan 1 year 1 is day=',i6)
3875 
3876  !==============================================================================================
3877  ! Tests of error message for invalid dates
3878 
3879  if(test16) then
3880  write(outunit,'(/,a)') '################################# test16 #################################'
3882  time = set_date(1900, 1, 32, err_msg=err_msg)
3883  if(err_msg == '') then
3884  write(outunit,'(a)') 'test16.1 fails'
3885  else
3886  write(outunit,'(a)') 'test16.1 successful: '//trim(err_msg)
3887  endif
3888 
3889  time = set_date(1900, 4, 31, err_msg=err_msg)
3890  if(err_msg == '') then
3891  write(outunit,'(a)') 'test16.2 fails'
3892  else
3893  write(outunit,'(a)') 'test16.2 successful: '//trim(err_msg)
3894  endif
3895 
3896  time = set_date(1900, 2, 29, err_msg=err_msg)
3897  if(err_msg == '') then
3898  write(outunit,'(a)') 'test16.3 fails'
3899  else
3900  write(outunit,'(a)') 'test16.3 successful: '//trim(err_msg)
3901  endif
3902 
3904  time = set_date(1900, 1, 0, err_msg=err_msg)
3905  if(err_msg == '') then
3906  write(outunit,'(a)') 'test16.4 fails'
3907  else
3908  write(outunit,'(a)') 'test16.4 successful: '//trim(err_msg)
3909  endif
3910 
3912  time = set_date(1900, 0, 1, err_msg=err_msg)
3913  if(err_msg == '') then
3914  write(outunit,'(a)') 'test16.5 fails'
3915  else
3916  write(outunit,'(a)') 'test16.5 successful: '//trim(err_msg)
3917  endif
3918 
3919  time = set_date(1900, 1, 1, tick=11, err_msg=err_msg)
3920  if(err_msg == '') then
3921  write(outunit,'(a)') 'test16.6 fails'
3922  else
3923  write(outunit,'(a)') 'test16.6 successful: '//trim(err_msg)
3924  endif
3925 
3927  time = set_date(1900, 13, 1, err_msg=err_msg)
3928  if(err_msg == '') then
3929  write(outunit,'(a)') 'test16.7 fails'
3930  else
3931  write(outunit,'(a)') 'test16.7 successful: '//trim(err_msg)
3932  endif
3933 
3934  time = set_date(1900, 12, 31, err_msg=err_msg)
3935  if(err_msg == '') then
3936  write(outunit,'(a)') 'test16.8 fails'
3937  else
3938  write(outunit,'(a)') 'test16.8 successful: '//trim(err_msg)
3939  endif
3940 
3942  time = set_date(1900, 4, 31, err_msg=err_msg)
3943  if(err_msg == '') then
3944  write(outunit,'(a)') 'test16.9 fails'
3945  else
3946  write(outunit,'(a)') 'test16.9 successful: '//trim(err_msg)
3947  endif
3948  endif
3949  !==============================================================================================
3950  ! Tests of Gregorian calendar
3951  ! This test loops through every day of an 400 year period and writes a line to the output file for each day.
3952 
3953  if(test17) then
3954  write(outunit,'(/,a)') '################################# test17 #################################'
3955  write(errunit,'(/,a)') ' ====================================================='
3956  write(errunit,'(a)') ' Warning: test17 produces voluminous output.'
3957  write(errunit,'(a)') ' It can be turned off with: &test_nml test17=.false./'
3958  write(errunit,'(a,/)') ' ====================================================='
3960  do year=1801,2200
3961  leap = mod(year,4) == 0
3962  leap = leap .and. .not.mod(year,100) == 0
3963  leap = leap .or. mod(year,400) == 0
3964  do month=1,12
3965  days_this_month = days_per_month(month)
3966  if(leap .and. month == 2) days_this_month = 29
3967  do dday=1,days_this_month
3968  time = set_date(year, month, dday, 0, 0, 0)
3969  call get_date(time, yr, mo, day, hr, min, sec)
3970  write(outunit,100) yr, mo, day, leap_year(time), days_in_month(time), days_in_year(time)
3971  enddo
3972  enddo
3973  enddo
3974  endif
3975  100 format('yr=',i4,' mo=',i2,' day=',i2,' leap=',l1,' days_in_month=',i2,' days_in_year=',i3)
3976  !==============================================================================================
3977  ! Tests of length_of_year
3978 
3979  if(test18) then
3980  write(outunit,'(/,a)') '################################# test18 #################################'
3982  call print_time(length_of_year(), 'length_of_year for THIRTY_DAY_MONTHS:', unit=outunit)
3984  call print_time(length_of_year(), 'length_of_year for NOLEAP:', unit=outunit)
3986  call print_time(length_of_year(), 'length_of_year for JULIAN:', unit=outunit)
3988  call print_time(length_of_year(), 'length_of_year for GREGORIAN:', unit=outunit)
3989  endif
3990  !==============================================================================================
3991  ! Tests of real_to_time_type
3992 
3993  if(test19) then
3994  write(outunit,'(/,a)') '################################# test19 #################################'
3995  call print_time(real_to_time_type(86401.1), 'real_to_time_type(86401.1):', unit=outunit)
3996  time = real_to_time_type(-1.0, err_msg)
3997  if(err_msg == '') then
3998  write(outunit,'(a)') 'test of real_to_time_type fails'
3999  else
4000  write(outunit,'(a)') 'test successful: '//trim(err_msg)
4001  endif
4002  endif
4003  !==============================================================================================
4004  write(outunit,'(/,a)') '############################################################################'
4005  write(outunit,'(a,i6)') ' ticks_per_second=',get_ticks_per_second()
4006 
4007  call fms_io_exit
4008  call fms_end
4009  end program test
4010 #endif
Definition: fms.F90:20
type(time_type) function, public increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
subroutine, public get_date(time, year, month, day, hour, minute, second, tick, err_msg)
logical function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg)
integer function, public get_ticks_per_second()
type(time_type) function, public increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
integer, parameter max_type
integer, parameter, public gregorian
subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick)
type(time_type) function, public length_of_year()
logical function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
void error_handler(const char *msg)
Definition: mosaic_util.c:55
type(time_type) function length_of_year_gregorian()
integer, parameter, public noleap
integer function days_in_month_thirty(Time)
type(time_type) function, public set_date_julian(year, month, day, hour, minute, second)
character(len=9) function, public month_name(n)
subroutine, public get_date_no_leap(time, year, month, day, hour, minute, second)
integer function time_divide(time1, time2)
integer, private calendar_type
type(time_type) function length_of_year_julian()
integer, parameter days_in_400_year_period
type(time_type) function length_of_year_no_leap()
logical function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
integer, parameter invalid_date
Definition: mpp.F90:39
integer function, public check_nml_error(IOSTAT, NML_NAME)
Definition: fms.F90:658
integer, dimension(days_in_400_year_period) coded_date
integer function days_in_month_gregorian(Time)
logical function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
integer function days_in_year_thirty(Time)
type(time_type) function set_time_c(string, err_msg, allow_rounding)
integer function days_in_year_no_leap(Time)
type(time_type) function length_of_year_thirty()
logical function leap_year_gregorian(Time)
character(len=input_str_length), dimension(:), allocatable, target, public input_nml_file
Definition: mpp.F90:1378
logical function, public interval_alarm(time, time_interval, alarm, alarm_interval)
subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick)
subroutine, public set_calendar_type(type, err_msg)
logical function set_time_private(seconds, days, ticks, Time_out, err_msg)
logical function get_tick_from_string(string, err_msg, allow_rounding, tick)
integer function days_in_month_no_leap(Time)
subroutine, public fms_init(localcomm)
Definition: fms.F90:353
integer function, public day_of_year(time)
logical function leap_year_gregorian_int(year)
character(len=15) function, public date_to_string(time, err_msg)
character(len=24) function, public valid_calendar_types(ncal, err_msg)
integer function, public days_in_month(Time, err_msg)
integer, parameter, public julian
subroutine, public time_list_error(T, Terr)
This routine converts the integer tdays to a string.
integer function, public get_calendar_type()
integer, parameter, public thirty_day_months
logical function leap_year_julian(Time)
logical function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
type(time_type) function set_time_i(seconds, days, ticks, err_msg)
type(time_type) function, public set_date_no_leap(year, month, day, hour, minute, second)
subroutine, public time_manager_init()
integer, dimension(400, 12, 31) date_to_day
integer function days_in_year_gregorian(Time)
integer, parameter, public no_calendar
character(len=256) function cut0(string)
integer function days_in_year_julian(Time)
integer, dimension(12), private days_per_month
logical function leap_year_thirty(Time)
type(time_type) function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
logical function, public leap_year(Time, err_msg)
subroutine, public fms_end()
Definition: fms.F90:476
type(time_type) function, public real_to_time_type(x, err_msg)
subroutine, public fms_io_exit()
Definition: fms_io.F90:750
logical function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg)
type(time_type) function, public decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc)
real(double_kind) function, public time_type_to_real(time)
#define max(a, b)
Definition: mosaic_util.h:33
subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick)
integer function, public days_in_year(Time)
logical function valid_increments(year, month, day, hour, minute, second, tick, err_msg)
integer function days_in_month_julian(Time)
integer ticks_per_second
logical function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg)
real, parameter, public seconds_per_day
Seconds in a day [s].
Definition: constants.F90:116
character(len=19) function convert_integer_date_to_char(year, month, day, hour, minute, second)
#define min(a, b)
Definition: mosaic_util.h:32
subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick)
subroutine, public get_time(Time, seconds, days, ticks, err_msg)
logical function, public repeat_alarm(time, alarm_frequency, alarm_length)
subroutine, public error_mesg(routine, message, level)
Definition: fms.F90:529
type(time_type) function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
integer, parameter, public invalid_calendar
subroutine, public print_time(Time, str, unit)
subroutine, public constants_init
dummy routine.
Definition: constants.F90:141
subroutine, public get_date_julian(time, year, month, day, hour, minute, second)
type(time_type) function scalar_time_mult(n, time)
type(time_type) function, public decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc)
subroutine, public print_date(Time, str, unit)
logical function leap_year_no_leap(Time)
logical module_is_initialized
subroutine, public set_ticks_per_second(tps)