diff --git a/test_fms/time_manager/Makefile.am b/test_fms/time_manager/Makefile.am index 61c2dc5aa8..a38a8c8969 100644 --- a/test_fms/time_manager/Makefile.am +++ b/test_fms/time_manager/Makefile.am @@ -23,7 +23,7 @@ # uramirez, Ed Hartnett # Find the fms_mod.mod file. -AM_CPPFLAGS = -I$(MODDIR) +AM_CPPFLAGS = -I$(MODDIR) -I../../include # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la @@ -32,7 +32,10 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_time_manager # This is the source code for the test. -test_time_manager_SOURCES = test_time_manager.F90 +test_time_manager_SOURCES = test_time_manager.F90 time_manager0.F90 + +time_manager0_mod.mod : time_manager0.$(OBJEXT) +test_time_manager.$(OBJEXT): time_manager0_mod.mod # Run the test program. TESTS = test_time_manager2.sh diff --git a/test_fms/time_manager/test_time_manager.F90 b/test_fms/time_manager/test_time_manager.F90 index 03d1419f0a..da3952a52a 100644 --- a/test_fms/time_manager/test_time_manager.F90 +++ b/test_fms/time_manager/test_time_manager.F90 @@ -24,7 +24,7 @@ program test_time_manager use fms_mod, only: open_namelist_file, check_nml_error, close_file, open_file use constants_mod, only: constants_init, rseconds_per_day=>seconds_per_day use fms_io_mod, only: fms_io_exit - use time_manager_mod, only: time_type, set_date, set_date2, get_date, get_date2, set_time, set_calendar_type, real_to_time_type + use time_manager_mod, only: time_type, set_date, get_date, set_time, set_calendar_type, real_to_time_type use time_manager_mod, only: length_of_year, leap_year, days_in_month, days_in_year, print_time use time_manager_mod, only: set_ticks_per_second, get_ticks_per_second use time_manager_mod, only: decrement_date, increment_date, get_time, increment_time, decrement_time @@ -32,6 +32,7 @@ program test_time_manager use time_manager_mod, only: operator(-), operator(+), operator(*), operator(/), & operator(>), operator(>=), operator(==), operator(/=), & operator(<), operator(<=), operator(//), assignment(=) + use time_manager0_mod, only: time_type0 => time_type implicit none @@ -570,14 +571,7 @@ program test_time_manager do dday=1,days_this_month Time = set_date(year, month, dday, 0, 0, 0) call get_date(Time, yr, mo, day, hr, min, sec) - call get_date2(Time, yr2, mo2, day2, hr2, min2, sec2) - if( yr.ne.yr2 .or. mo.ne.mo2 .or. day.ne.day2 ) then - write(outunit,*) 'YEAR', yr, 'YEAR2', yr2 - write(outunit,*) 'MONTH', mo, 'MONTH2', mo2 - write(outunit,*) 'DAY', day, 'DAY2', day2 - call mpp_error(FATAL,'Error in get_date2') - end if - !write(outunit,100) yr, mo, day, leap_year(Time), days_in_month(Time), days_in_year(Time) + write(outunit,100) yr, mo, day, leap_year(Time), days_in_month(Time), days_in_year(Time) enddo enddo enddo @@ -615,35 +609,6 @@ program test_time_manager write(outunit,'(a,i6)') ' ticks_per_second=',get_ticks_per_second() !============================================================================================== - ! Tests Gregorian calendar set_date - ! This test loops through every day of an 400 year period and writes a line to the output file for each day. - - write(outunit,'(/,a)') '################################# test set_date #################################' - call set_calendar_type(GREGORIAN) - do year=1601,2200 - leap = mod(year,4) == 0 - leap = leap .and. .not.mod(year,100) == 0 - leap = leap .or. mod(year,400) == 0 - do month=1,12 - days_this_month = days_per_month(month) - if(leap .and. month == 2) days_this_month = 29 - do dday=1,days_this_month - Time = set_date(year, month, dday, 0, 0, 0) - Time22 = set_date2(year, month, dday, 0, 0, 0,chooseme=.True.) - call get_date(Time, yr, mo, day, hr, min, sec) - call get_date(Time22, yr2, mo2, day2, hr2, min2, sec2) - if( yr.ne.yr2 .or. mo.ne.mo2 .or. day.ne.day2 ) then - write(outunit,*) 'YEAR', yr, 'YEAR2', yr2 - write(outunit,*) 'MONTH', mo, 'MONTH2', mo2 - write(outunit,*) 'DAY', day, 'DAY2', day2 - call mpp_error(FATAL,'Error in get_date2') - end if - !write(outunit,100) yr, mo, day, leap_year(Time), days_in_month(Time), days_in_year(Time) - enddo - enddo - enddo - write(outunit,*) 'done' - !============================================================================================== call fms_io_exit diff --git a/test_fms/time_manager/time_manager0.F90 b/test_fms/time_manager/time_manager0.F90 new file mode 100644 index 0000000000..9a6872c93d --- /dev/null +++ b/test_fms/time_manager/time_manager0.F90 @@ -0,0 +1,3430 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +module time_manager0_mod + +! +! fms +! + +! + +! +! A software package that provides a set of simple interfaces for +! modelers to perform computations related to time and dates. +! + +! +! The changes between the lima revision and this revision are more +! extensive that all those between antwerp and lima. +! A brief description of these changes follows. +! +! 1) Added option to set the smallest time increment to something less than one second. +! This is controlled by calling the pubic subroutine set_ticks_per_second. +! +! 2) Gregorian calendar fixed. +! +! 3) Optional error flag added to calling arguments of public routines. +! This allows the using routine to terminate the program. It is likely that more +! diagnostic information is available from the user than from time_manager alone. +! If the error flag is present then it is the responsibility of the using +! routine to test it and add additional information to the error message. +! +! 4) Removed the restriction that time increments be positive in routines that increment or decrement +! time and date. The option to prohibit negative increments can be turned on via optional argument. +! +! 5) subroutine set_date_c modified to handle strings that include only hours or only hours and minutes. +! This complies with CF convensions. +! +! 6) Made calendar specific routines private. +! They are not used, and should not be used, by any using code. +! +! 7) Error messages made more informative. +! +! The module defines a type that can be used to represent discrete +! times (accurate to one second) and to map these times into dates +! using a variety of calendars. A time is mapped to a date by +! representing the time with respect to an arbitrary base date (refer +! to NOTES section for the base date setting). +! +! The time_manager provides a single defined type, time_type, which is +! used to store time and date quantities. A time_type is a positive +! definite quantity that represents an interval of time. It can be +! most easily thought of as representing the number of seconds in some +! time interval. A time interval can be mapped to a date under a given +! calendar definition by using it to represent the time that has passed +! since some base date. A number of interfaces are provided to operate +! on time_type variables and their associated calendars. Time intervals +! can be as large as n days where n is the largest number represented by +! the default integer type on a compiler. This is typically considerably +! greater than 10 million years (assuming 32 bit integer representation) +! which is likely to be adequate for most applications. The description +! of the interfaces is separated into two sections. The first deals with +! operations on time intervals while the second deals with operations +! that convert time intervals to dates for a given calendar. + +! The smallest increment of time is referred to as a tick. +! A tick cannot be larger than 1 second, which also is the default. +! The number of ticks per second is set via pubic subroutine set_ticks_per_second. +! For example, ticks_per_second = 1000 will set the tick to one millisecond. +! + +! +! Derived-type data variable used to store time and date quantities. It +! contains three PRIVATE variables: days, seconds and ticks. +! + +use platform_mod, only: r8_kind +use constants_mod, only: rseconds_per_day=>seconds_per_day +use fms_mod, only: error_mesg, FATAL, WARNING, write_version_number, stdout + +implicit none +private + +! Module defines a single type +public time_type + +! Operators defined on time_type +public operator(+), operator(-), operator(*), operator(/), & + operator(>), operator(>=), operator(==), operator(/=), & + operator(<), operator(<=), operator(//), assignment(=) + +! Subroutines and functions operating on time_type +public set_time, increment_time, decrement_time, get_time, interval_alarm +public repeat_alarm, time_type_to_real, real_to_time_type +public time_list_error + +! List of available calendar types +public THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR + +! Subroutines and functions involving relations between time and calendar +public set_calendar_type +public get_calendar_type +public set_ticks_per_second +public get_ticks_per_second +public set_date +public get_date +public increment_date +public decrement_date +public days_in_month +public leap_year +public length_of_year +public days_in_year +public day_of_year +public month_name + +public valid_calendar_types + +! Subroutines for printing version number and time type +public :: time_manager_init, print_time, print_date + +! The following exist only for interpolator.F90 +! interpolator.F90 uses them to do a calendar conversion, +! which is also done by get_cal_time. interpolator.F90 +! should be modified to use get_cal_time instead. +! After interpolator.F90 is fixed, these can be removed +! and the corresponding private routines can be renamed. +! (e.g., rename set_date_julian_private to be just set_date_julian) +public :: set_date_julian, set_date_no_leap, get_date_julian, get_date_no_leap + +public :: date_to_string + +!==================================================================== + +! Global data to define calendar type +integer, parameter :: THIRTY_DAY_MONTHS = 1, JULIAN = 2, & + GREGORIAN = 3, NOLEAP = 4, & + NO_CALENDAR = 0, INVALID_CALENDAR =-1 +integer, private :: calendar_type = NO_CALENDAR +integer, parameter :: max_type = 4 + +! Define number of days per month +integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) +integer, parameter :: seconds_per_day = rseconds_per_day ! This should automatically cast real to integer +integer, parameter :: days_in_400_year_period = 146097 ! Used only for gregorian +integer, dimension(days_in_400_year_period) :: coded_date ! Used only for gregorian +integer, dimension(400,12,31) :: date_to_day ! Used only for gregorian +integer, parameter :: invalid_date=-1 ! Used only for gregorian +integer,parameter :: do_floor = 0 +integer,parameter :: do_nearest = 1 + + +! time_type is implemented as seconds and days to allow for larger intervals +type time_type + private + integer:: seconds + integer:: days + integer:: ticks + integer:: dummy ! added as a workaround bug on IRIX64 (AP) +end type time_type + +!====================================================================== + +interface operator (+); module procedure time_plus; end interface +interface operator (-); module procedure time_minus; end interface +interface operator (*); module procedure time_scalar_mult + module procedure scalar_time_mult; end interface +interface operator (/); module procedure time_scalar_divide + module procedure time_divide; end interface +interface operator (>); module procedure time_gt; end interface +interface operator (>=); module procedure time_ge; end interface +interface operator (<); module procedure time_lt; end interface +interface operator (<=); module procedure time_le; end interface +interface operator (==); module procedure time_eq; end interface +interface operator (/=); module procedure time_ne; end interface +interface operator (//); module procedure time_real_divide; end interface +interface assignment(=); module procedure time_assignment; end interface + +!====================================================================== + +interface set_time + module procedure set_time_i, set_time_c +end interface + +interface set_date + module procedure set_date_i, set_date_c +end interface + +!====================================================================== + +! Include variable "version" to be written to log file. +#include +logical :: module_is_initialized = .false. + +!====================================================================== + +! A tick is the smallest increment of time. +! That is, smallest increment of time = (1/ticks_per_second) seconds + +integer :: ticks_per_second = 1 + +!====================================================================== +contains + +! First define all operations on time intervals independent of calendar + +!========================================================================= +! + +! +! Given some number of seconds and days, returns the +! corresponding time_type. +! +! +! Given some number of seconds and days, returns the +! corresponding time_type. set_time has two forms; +! one accepts integer input, the other a character string. +! For the first form, there are no restrictions on the range of the inputs, +! except that the result must be positive time. +! e.g. days=-1, seconds=86401 is acceptable. +! For the second form, days and seconds must both be positive. +! +! +! + +! +! A number of seconds. +! +! +! A number of days. +! +! +! A number of ticks. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! +! Contains days and seconds separated by a single blank. +! days must be integer, seconds may be integer or real. +! Examples: '100 43200' '100 43200.50' +! +! +! When .true., any fractions of a second will be rounded off to the nearest tick. +! When .false., it is a fatal error if the second fraction cannot be exactly +! represented by a number of ticks. +! +! +! A time interval corresponding to this number of days and seconds. +! + + function set_time_private(seconds, days, ticks, Time_out, err_msg) + +! Returns a time interval corresponding to this number of days, seconds, and ticks. +! days, seconds and ticks may be negative, but resulting time must be positive. + +! -- pjp -- +! To understand why inputs may be negative, +! one needs to understand the intrinsic function "modulo". +! The expanation below is copied from a web page on fortran 90 + +! In addition, CEILING, FLOOR and MODULO have been added to Fortran 90. +! Only the last one is difficult to explain, which is most easily done with the examples from ISO (1991) + +! MOD (8,5) gives 3 MODULO (8,5) gives 3 +! MOD (-8,5) gives -3 MODULO (-8,5) gives 2 +! MOD (8,-5) gives 3 MODULO (8,-5) gives -2 +! MOD (-8,-5) gives -3 MODULO (-8,-5) gives -3 + +! I don't think it is difficult to explain. +! I think that is it sufficient to say this: +! "The result of modulo(n,m) has the sign of m" +! -- pjp -- + + logical :: set_time_private + integer, intent(in) :: seconds, days, ticks + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + integer :: seconds_new, days_new, ticks_new + + seconds_new = seconds + floor(ticks/real(ticks_per_second)) + ticks_new = modulo(ticks,ticks_per_second) + days_new = days + floor(seconds_new/real(seconds_per_day)) + seconds_new = modulo(seconds_new,seconds_per_day) + + if ( seconds_new < 0 .or. ticks_new < 0) then + call error_mesg('function set_time_i','Bad result for time. Contact those responsible for maintaining time_manager',FATAL) + endif + + if(days_new < 0) then + write(err_msg,'(a,i6,a,i6,a,i6)') 'time is negative. days=',days_new,' seconds=',seconds_new,' ticks=',ticks_new + set_time_private = .false. + else + Time_out%days = days_new + Time_out%seconds = seconds_new + Time_out%ticks = ticks_new + err_msg = '' + set_time_private = .true. + endif + + end function set_time_private +!--------------------------------------------------------------------------- + + function set_time_i(seconds, days, ticks, err_msg) + type(time_type) :: set_time_i + integer, intent(in) :: seconds + integer, intent(in), optional :: days, ticks + character(len=*), intent(out), optional :: err_msg + character(len=128) :: err_msg_local + integer :: odays, oticks + + if(.not.module_is_initialized) call time_manager_init + + odays = 0; if(present(days)) odays = days + oticks = 0; if(present(ticks)) oticks = ticks + if(present(err_msg)) err_msg = '' + + if(.not.set_time_private(seconds, odays, oticks, set_time_i, err_msg_local)) then + if(error_handler('function set_time_i', trim(err_msg_local), err_msg)) return + endif + + end function set_time_i +!--------------------------------------------------------------------------- + + function set_time_c(string, err_msg, allow_rounding) + + type(time_type) :: set_time_c + character(len=*), intent(in) :: string + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: allow_rounding + + character(len=4) :: formt='(i )' + integer :: i1, i2, i3, day, second, tick, nsps + character(len=32) :: string_sifted_left + character(len=128) :: err_msg_local + logical :: allow_rounding_local + + if(.not.module_is_initialized) call time_manager_init + if(present(err_msg)) err_msg = '' + allow_rounding_local=.true.; if(present(allow_rounding)) allow_rounding_local=allow_rounding + + err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string) + + string_sifted_left = adjustl(string) + i1 = index(trim(string_sifted_left),' ') + if(i1 == 0) then + if(error_handler('function set_time_c', err_msg_local, err_msg)) return + endif + if(index(string,'-') /= 0 .or. index(string,':') /= 0) then + if(error_handler('function set_time_c', err_msg_local, err_msg)) return + endif + + i2 = index(trim(string_sifted_left),'.') + i3 = len_trim(cut0(string_sifted_left)) + + if(i2 /= 0) then ! There is no decimal point + ! Check that decimal is on seconds (not days) + if(i2 < i1) then + if(error_handler('function set_time_c', err_msg_local, err_msg)) return + endif + endif + write(formt(3:3),'(i1)') i1-1 + read(string_sifted_left(1:i1-1),formt) day + + if(i2 == 0) then ! There is no decimal point + write(formt(3:3),'(i1)') i3-i1 + read(string_sifted_left(i1+1:i3),formt) second + tick = 0 + else ! There is a decimal point + ! nsps = spaces occupied by whole number of seconds + nsps = i2-i1-1 + if(nsps == 0) then + second = 0 + else + write(formt(3:3),'(i1)') nsps + read(string_sifted_left(i1+1:i2-1),formt) second + endif + + if(.not.get_tick_from_string(string_sifted_left(i2:i3), err_msg_local, allow_rounding_local, tick)) then + if(error_handler('function set_time_c', err_msg_local, err_msg)) return + endif + ! If tick has been rounded up to ticks_per_second, then bump up second. + if(tick == ticks_per_second) then + second = second + 1 + tick = 0 + endif + endif + + if(.not.set_time_private(second, day, tick, set_time_c, err_msg_local)) then + if(error_handler('function set_time_c', err_msg_local, err_msg)) return + endif + + end function set_time_c +!--------------------------------------------------------------------------- +! + + function get_tick_from_string(string, err_msg, allow_rounding, tick) + + logical :: get_tick_from_string + character(len=*), intent(in) :: string + character(len=*), intent(out) :: err_msg + logical, intent(in) :: allow_rounding + integer, intent(out) :: tick + + character(len=4) :: formt='(i )' + integer :: i3, nspf, fraction, magnitude, tpsfrac + + err_msg = '' + get_tick_from_string = .true. + i3 = len_trim(string) + nspf = i3 - 1 ! nspf = spaces occupied by fractional seconds, excluding decimal point + if(nspf == 0) then + tick = 0 ! Nothing to the right of the decimal point + else + write(formt(3:3),'(i1)') nspf + read(string(2:i3),formt) fraction + if(fraction == 0) then + tick = 0 ! All zeros to the right of the decimal point + else + magnitude = 10**nspf + tpsfrac = ticks_per_second*fraction + if(allow_rounding) then + tick = nint((real(tpsfrac)/magnitude)) + else + if(modulo(tpsfrac,magnitude) == 0) then + tick = tpsfrac/magnitude + else + write(err_msg,'(a,i6)') 'Second fraction cannot be exactly represented with ticks. '// & + 'fraction='//trim(string)//' ticks_per_second=',ticks_per_second + get_tick_from_string = .false. + endif + endif + endif + endif + + end function get_tick_from_string +!--------------------------------------------------------------------------- +! + +! +! Given a time interval, returns the corresponding seconds and days. +! +! +! Given a time interval, returns the corresponding seconds and days. +! +! + +! +! A time interval. +! +! +! A number of seconds. +! +! +! A number of days. +! +! +! A number of ticks. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! + +subroutine get_time(Time, seconds, days, ticks, err_msg) + +! Returns days and seconds ( < 86400 ) corresponding to a time. + +type(time_type), intent(in) :: Time +integer, intent(out) :: seconds +integer, intent(out), optional :: days, ticks +character(len=*), intent(out), optional :: err_msg +character(len=128) :: err_msg_local + +if(.not.module_is_initialized) call time_manager_init +if(present(err_msg)) err_msg = '' + +seconds = Time%seconds + +if(present(ticks)) then + ticks = Time%ticks +else + if(Time%ticks /= 0) then + err_msg_local = 'subroutine get_time: ticks must be present when time has a second fraction' + if(error_handler('subroutine get_time', err_msg_local, err_msg)) return + endif +endif + +if (present(days)) then + days = Time%days +else + if (Time%days > (huge(seconds) - seconds)/seconds_per_day) then + err_msg_local = 'Integer overflow in seconds. Optional argument days must be present.' + if(error_handler('subroutine get_time', err_msg_local, err_msg)) return + endif + seconds = seconds + Time%days * seconds_per_day +endif + +end subroutine get_time +! + +!------------------------------------------------------------------------- +! + +! +! Given a time and an increment of days and seconds, returns +! a time that adds this increment to an input time. +! +! +! Given a time and an increment of days and seconds, returns +! a time that adds this increment to an input time. +! Increments a time by seconds and days. +! +! + +! +! A time interval. +! +! +! Increment of seconds. +! +! +! Increment of days. +! +! +! Increment of ticks. +! +! +! A time that adds this increment to the input time. +! A negative result is a fatal error. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! +! When .false., it is a fatal error if any of the input time increments are negative. +! This mimics the behavior of lima and earlier revisions. +! + + function increment_time(Time, seconds, days, ticks, err_msg, allow_neg_inc) + +! Increments a time by seconds, days and ticks. + + type(time_type) :: increment_time + type(time_type), intent(in) :: Time + integer, intent(in) :: seconds + integer, intent(in), optional :: days, ticks + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: allow_neg_inc + + integer :: odays, oticks + character(len=128) :: err_msg_local + logical :: allow_neg_inc_local + + odays = 0; if(present(days)) odays = days + oticks = 0; if(present(ticks)) oticks = ticks + allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc + + if(.not.allow_neg_inc_local) then + if(seconds < 0 .or. odays < 0 .or. oticks < 0) then + write(err_msg_local,10) seconds, odays, oticks + 10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6) + if(error_handler('function increment_time', err_msg_local, err_msg)) return + endif + endif + + if(.not.increment_time_private(Time, seconds, odays, oticks, increment_time, err_msg_local)) then + if(error_handler('function increment_time', err_msg_local, err_msg)) return + endif + + end function increment_time +! +!-------------------------------------------------------------------------- + + function increment_time_private(Time_in, seconds, days, ticks, Time_out, err_msg) + +! Increments a time by seconds, days and ticks. + + logical :: increment_time_private + type(time_type), intent(in) :: Time_in + integer, intent(in) :: seconds, days, ticks + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + +! Watch for immediate overflow on days or seconds + if(days >= huge(days) - Time_in%days) then + err_msg = 'Integer overflow in days in increment_time' + increment_time_private = .false. + return + endif + if(seconds >= huge(seconds) - Time_in%seconds) then + err_msg = 'Integer overflow in seconds in increment_time' + increment_time_private = .false. + return + endif + + increment_time_private = set_time_private(Time_in%seconds+seconds, Time_in%days+days, Time_in%ticks+ticks, Time_out, err_msg) + + end function increment_time_private + +!-------------------------------------------------------------------------- +! + +! +! Given a time and a decrement of days and seconds, returns +! a time that subtracts this decrement from an input time. +! +! +! Decrements a time by seconds and days. +! +! + +! +! A time interval. +! +! +! Decrement of seconds. +! +! +! Decrement of days. +! +! +! Decrement of ticks. +! +! +! A time that subtracts this decrement from an input time. +! A negative result is a fatal error. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! +! When .false., it is a fatal error if any of the input time increments are negative. +! This mimics the behavior of lima and earlier revisions. +! + +function decrement_time(Time, seconds, days, ticks, err_msg, allow_neg_inc) + +! Decrements a time by seconds, days and ticks. + +type(time_type) :: decrement_time +type(time_type), intent(in) :: Time +integer, intent(in) :: seconds +integer, intent(in), optional :: days, ticks +character(len=*), intent(out), optional :: err_msg +logical, intent(in), optional :: allow_neg_inc + +integer :: odays, oticks +character(len=128) :: err_msg_local +logical :: allow_neg_inc_local + +odays = 0; if (present(days)) odays = days +oticks = 0; if (present(ticks)) oticks = ticks +allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc + +if(.not.allow_neg_inc_local) then + if(seconds < 0 .or. odays < 0 .or. oticks < 0) then + write(err_msg_local,10) seconds,odays,oticks + 10 format('One or more time increments are negative: seconds=',i6,' days=',i6,' ticks=',i6) + if(error_handler('function decrement_time', err_msg_local, err_msg)) return + endif +endif + + if(.not.increment_time_private(Time, -seconds, -odays, -oticks, decrement_time, err_msg_local)) then + if(error_handler('function decrement_time', err_msg_local, err_msg)) return + endif + +end function decrement_time +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 > time2. +! +! +! Returns true if time1 > time2. +! +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 > time2 +! +! + +function time_gt(time1, time2) + +! Returns true if time1 > time2 + +logical :: time_gt +type(time_type), intent(in) :: time1, time2 + +time_gt = (time1%days > time2%days) +if(time1%days == time2%days) then + if(time1%seconds == time2%seconds) then + time_gt = (time1%ticks > time2%ticks) + else + time_gt = (time1%seconds > time2%seconds) + endif +endif + +end function time_gt +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 >= time2. +! +! +! Returns true if time1 >= time2. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 >= time2 +! + +function time_ge(time1, time2) + +! Returns true if time1 >= time2 + +logical :: time_ge +type(time_type), intent(in) :: time1, time2 + +time_ge = (time_gt(time1, time2) .or. time_eq(time1, time2)) + +end function time_ge +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 < time2. +! +! +! Returns true if time1 < time2. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 < time2 +! + +function time_lt(time1, time2) + +! Returns true if time1 < time2 + +logical :: time_lt +type(time_type), intent(in) :: time1, time2 + +time_lt = (time1%days < time2%days) +if(time1%days == time2%days)then + if(time1%seconds == time2%seconds) then + time_lt = (time1%ticks < time2%ticks) + else + time_lt = (time1%seconds < time2%seconds) + endif +endif +end function time_lt +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 <= time2. +! +! +! Returns true if time1 <= time2. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 <= time2 +! + +function time_le(time1, time2) + +! Returns true if time1 <= time2 + +logical :: time_le +type(time_type), intent(in) :: time1, time2 + +time_le = (time_lt(time1, time2) .or. time_eq(time1, time2)) + +end function time_le +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 == time2. +! +! +! Returns true if time1 == time2. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 == time2 +! + +function time_eq(time1, time2) + +! Returns true if time1 == time2 + +logical :: time_eq +type(time_type), intent(in) :: time1, time2 + +if(.not.module_is_initialized) call time_manager_init + +time_eq = (time1%seconds == time2%seconds .and. time1%days == time2%days & + .and. time1%ticks == time2%ticks) + +end function time_eq +! + +!-------------------------------------------------------------------------- +! + +! +! Returns true if time1 /= time2. +! +! +! Returns true if time1 /= time2. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns true if time1 /= time2 +! + +function time_ne(time1, time2) + +! Returns true if time1 /= time2 + +logical :: time_ne +type(time_type), intent(in) :: time1, time2 + +time_ne = (.not. time_eq(time1, time2)) + +end function time_ne +! + +!------------------------------------------------------------------------- +! + +! +! Returns sum of two time_types. +! +! +! +! Returns sum of two time_types. +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns sum of two time_types. +! + +function time_plus(time1, time2) + +! Returns sum of two time_types + +type(time_type) :: time_plus +type(time_type), intent(in) :: time1, time2 + +if(.not.module_is_initialized) call time_manager_init + +time_plus = increment_time(time1, time2%seconds, time2%days, time2%ticks) + +end function time_plus +! + +!------------------------------------------------------------------------- +! + +! +! Returns difference of two time_types. +! +! +! Returns difference of two time_types. WARNING: a time type is positive +! so by definition time1 - time2 is the same as time2 - time1. +! +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns difference of two time_types. +! + +function time_minus(time1, time2) + +! Returns difference of two time_types. WARNING: a time type is positive +! so by definition time1 - time2 is the same as time2 - time1. + +type(time_type) :: time_minus +type(time_type), intent(in) :: time1, time2 + +if(.not.module_is_initialized) call time_manager_init + +if(time1 > time2) then + time_minus = decrement_time(time1, time2%seconds, time2%days, time2%ticks) +else + time_minus = decrement_time(time2, time1%seconds, time1%days, time1%ticks) +endif + +end function time_minus +! + +!-------------------------------------------------------------------------- +! + +! +! Returns time multiplied by integer factor n. +! +! +! Returns time multiplied by integer factor n. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns time multiplied by integer factor n. +! + +function time_scalar_mult(time, n) + +! Returns time multiplied by integer factor n + +type(time_type) :: time_scalar_mult +type(time_type), intent(in) :: time +integer, intent(in) :: n +integer :: days, seconds, ticks, num_sec +double precision :: sec_prod, tick_prod + +if(.not.module_is_initialized) call time_manager_init + +! Multiplying here in a reasonable fashion to avoid overflow is tricky +! Could multiply by some large factor n, and seconds could be up to 86399 +! Need to avoid overflowing integers and wrapping around to negatives +! ticks could be up to ticks_per_second-1 + +tick_prod = dble(time%ticks) * dble(n) +num_sec = tick_prod/dble(ticks_per_second) +sec_prod = dble(time%seconds) * dble(n) + num_sec +ticks = tick_prod - num_sec * ticks_per_second + +! If sec_prod is large compared to precision of double precision, things +! can go bad. Need to warn and abort on this. +! The same is true of tick_prod but is is more likely to happen to sec_prod, +! so let's just test sec_prod. (A test of tick_prod would be necessary only +! if ticks_per_second were greater than seconds_per_day) +if(sec_prod /= 0.0) then + if(log10(sec_prod) > precision(sec_prod) - 3) call error_mesg('time_scalar_mult', & + 'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',FATAL) +end if + +days = sec_prod / dble(seconds_per_day) +seconds = sec_prod - dble(days) * dble(seconds_per_day) + +time_scalar_mult = set_time(seconds, time%days * n + days, ticks) + +end function time_scalar_mult +! + +!------------------------------------------------------------------------- +! + +! +! Returns time multiplied by integer factor n. +! +! +! Returns time multiplied by integer factor n. +! +! + +! A time interval. +! An integer. +! +! Returns time multiplied by integer factor n. +! + +function scalar_time_mult(n, time) + +! Returns time multipled by integer factor n + +type(time_type) :: scalar_time_mult +type(time_type), intent(in) :: time +integer, intent(in) :: n + +scalar_time_mult = time_scalar_mult(time, n) + +end function scalar_time_mult +! + +!------------------------------------------------------------------------- +! + +! +! Returns the largest integer, n, for which time1 >= time2 * n. +! +! +! Returns the largest integer, n, for which time1 >= time2 * n. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns the largest integer, n, for which time1 >= time2 * n. +! + +function time_divide(time1, time2) + +! Returns the largest integer, n, for which time1 >= time2 * n. + +integer :: time_divide +type(time_type), intent(in) :: time1, time2 +double precision :: d1, d2 + +if(.not.module_is_initialized) call time_manager_init + +! Convert time intervals to floating point days; risky for general performance? +d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + time1%ticks/dble(ticks_per_second) +d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + time2%ticks/dble(ticks_per_second) + +! Get integer quotient of this, check carefully to avoid round-off problems. +time_divide = d1 / d2 + +! Verify time_divide*time2 is <= time1 and (time_divide + 1)*time2 is > time1 +if(time_divide * time2 > time1 .or. (time_divide + 1) * time2 <= time1) & + call error_mesg('time_divide',' quotient error :: notify developer',FATAL) + +end function time_divide +! + +!------------------------------------------------------------------------- +! + +! +! Returns the double precision quotient of two times. +! +! +! Returns the double precision quotient of two times. +! +! + +! +! A time interval. +! +! +! A time interval. +! +! +! Returns the double precision quotient of two times +! + +function time_real_divide(time1, time2) + +! Returns the double precision quotient of two times + +double precision :: time_real_divide +type(time_type), intent(in) :: time1, time2 +double precision :: d1, d2 + +if(.not.module_is_initialized) call time_manager_init + +! Convert time intervals to floating point seconds; risky for general performance? +d1 = time1%days * dble(seconds_per_day) + dble(time1%seconds) + dble(time1%ticks)/dble(ticks_per_second) +d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + dble(time2%ticks)/dble(ticks_per_second) + +time_real_divide = d1 / d2 + +end function time_real_divide +! + +!------------------------------------------------------------------------- +! + +! +! Assigns all components of the time_type variable on +! RHS to same components of time_type variable on LHS. +! +! +! Assigns all components of the time_type variable on +! RHS to same components of time_type variable on LHS. +! +! + +! +! A time type variable. +! +! +! A time type variable. +! + +subroutine time_assignment(time1, time2) +type(time_type), intent(out) :: time1 +type(time_type), intent(in) :: time2 + time1%seconds = time2%seconds + time1%days = time2%days + time1%ticks = time2%ticks +end subroutine time_assignment +! + +!------------------------------------------------------------------------- +! +! +! Converts time to seconds and returns it as a real number +! +! +! Converts time to seconds and returns it as a real number +! +! +! +! A time interval. +! + +function time_type_to_real(time) + +real(kind=r8_kind) :: time_type_to_real +type(time_type), intent(in) :: time + +if(.not.module_is_initialized) call time_manager_init + +time_type_to_real = dble(time%days) * 86400.d0 + dble(time%seconds) + & + dble(time%ticks)/dble(ticks_per_second) + +end function time_type_to_real + +!> @brief Convert a real number of seconds into a time_type variable. +!! @return A filled time type variable, and an error message if an +!! error occurs. +function real_to_time_type(x,err_msg) result(t) + real,intent(in) :: x !< Number of seconds. + character(len=*),intent(out),optional :: err_msg !< Error message. + type(time_type) :: t + integer :: days + integer :: seconds + integer :: ticks + character(len=128) :: err_msg_local + real,parameter :: spd = real(86400) + real :: tps + real :: a + tps = real(ticks_per_second) + a = x/spd + days = safe_rtoi(a,do_floor) + a = x - real(days)*spd + seconds = safe_rtoi(a,do_floor) + a = (a - real(seconds))*tps + ticks = safe_rtoi(a,do_nearest) + if (.not. set_time_private(seconds,days,ticks,t,err_msg_local)) then + if (error_handler('function real_to_time_type',err_msg_local,err_msg)) then + return + endif + endif +end function real_to_time_type + +!> @brief Convert a floating point value to an integer value. +!! @return The integer value, using the input rounding mode. +function safe_rtoi(rval,mode) result(ival) + real,intent(in) :: rval !< A floating point value. + integer,intent(in) :: mode !< A rouding mode (either "do_floor" or + !! "do_nearest") + integer :: ival + real :: big + big = real(huge(ival)) + if (rval .le. big .and. -1.*rval .ge. -1.*big) then + if (mode .eq. do_floor) then + ival = floor(rval) + elseif (mode .eq. do_nearest) then + ival = nint(rval) + else + call error_mesg("safe_rtoi","mode must be either do_floor" & + //" or do_nearest.",FATAL) + endif + else + call error_mesg("safe_rtoi","input value cannot be safely" & + //" converted to a 32-bit integer.",FATAL) + endif +end function safe_rtoi + +!------------------------------------------------------------------------- +! + +! +! Returns the largest time, t, for which n * t <= time. +! +! +! Returns the largest time, t, for which n * t <= time. +! +! + +! +! A time interval. +! +! +! An integer factor. +! +! +! Returns the largest time, t, for which n * t <= time. +! + +function time_scalar_divide(time, n) + +! Returns the largest time, t, for which n * t <= time + +type(time_type) :: time_scalar_divide +type(time_type), intent(in) :: time +integer, intent(in) :: n +double precision :: d, div, dseconds_per_day, dticks_per_second +integer :: days, seconds, ticks +type(time_type) :: prod1, prod2 +character(len=128) tmp1,tmp2 +logical :: ltmp + +! Convert time interval to floating point days; risky for general performance? +dseconds_per_day = dble(seconds_per_day) +dticks_per_second = dble(ticks_per_second) +d = time%days*dseconds_per_day*dticks_per_second + dble(time%seconds)*dticks_per_second + dble(time%ticks) +div = d/dble(n) + +days = div/(dseconds_per_day*dticks_per_second) +seconds = div/dticks_per_second - days*dseconds_per_day +ticks = div - (days*dseconds_per_day + dble(seconds))*dticks_per_second +time_scalar_divide = set_time(seconds, days, ticks) + +! Need to make sure that roundoff isn't killing this +prod1 = n * time_scalar_divide +prod2 = n * (increment_time(time_scalar_divide, days=0, seconds=0, ticks=1)) +if(prod1 > time .or. prod2 <= time) then + call get_time(time, seconds, days, ticks) + write(tmp1,20) days,seconds,ticks + call get_time(time_scalar_divide, seconds, days, ticks) + write(tmp2,30) n,days,seconds,ticks + ltmp = error_handler('time_scalar_divide',' quotient error:'//trim(tmp1)//trim(tmp2)) + 20 format('time=',i7,' days, ',i6,' seconds, ',i6,' ticks') + 30 format(' time divided by',i6,'=',i7,' days, ',i6,' seconds, ',i6,' ticks') +endif + +end function time_scalar_divide +! + +!------------------------------------------------------------------------- +! + +! +! Given a time, and a time interval, this function returns true +! if this is the closest time step to the alarm time. +! +! +! This is a specialized operation that is frequently performed in models. +! Given a time, and a time interval, this function is true if this is the +! closest time step to the alarm time. The actual computation is: +! +! if((alarm_time - time) <= (time_interval / 2)) +! +! If the function is true, the alarm time is incremented by the +! alarm_interval; WARNING, this is a featured side effect. Otherwise, the +! function is false and there are no other effects. CAUTION: if the +! alarm_interval is smaller than the time_interval, the alarm may fail to +! return true ever again. Watch +! for problems if the new alarm time is less than time + time_interval +! +! + +! Current time. +! A time interval. +! A time interval. +! +! Returns either True or false. +! +! +! An alarm time, which is incremented by the alarm_interval +! if the function is true. +! + +function interval_alarm(time, time_interval, alarm, alarm_interval) + +! Supports a commonly used type of test on times for models. Given the +! current time, and a time for an alarm, determines if this is the closest +! time to the alarm time given a time step of time_interval. If this +! is the closest time (alarm - time <= time_interval/2), the function +! returns true and the alarm is incremented by the alarm_interval. Watch +! for problems if the new alarm time is less than time + time_interval + +logical :: interval_alarm +type(time_type), intent(in) :: time, time_interval, alarm_interval +type(time_type), intent(inout) :: alarm + +if((alarm - time) <= (time_interval / 2)) then + interval_alarm = .TRUE. + alarm = alarm + alarm_interval +else + interval_alarm = .FALSE. +end if + +end function interval_alarm +! + +!-------------------------------------------------------------------------- +! + +! +! Repeat_alarm supports an alarm that goes off with +! alarm_frequency and lasts for alarm_length. +! +! +! Repeat_alarm supports an alarm that goes off with alarm_frequency and +! lasts for alarm_length. If the nearest occurence of an alarm time +! is less than half an alarm_length from the input time, repeat_alarm +! is true. For instance, if the alarm_frequency is 1 day, and the +! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on +! day n to time 0100 on day n + 1 for all n. +! +! + +! Current time. +! +! A time interval for alarm_frequency. +! +! +! A time interval for alarm_length. +! +! +! Returns either True or false. +! + +function repeat_alarm(time, alarm_frequency, alarm_length) + +! Repeat_alarm supports an alarm that goes off with alarm_frequency and +! lasts for alarm_length. If the nearest occurence of an alarm time +! is less than half an alarm_length from the input time, repeat_alarm +! is true. For instance, if the alarm_frequency is 1 day, and the +! alarm_length is 2 hours, then repeat_alarm is true from time 2300 on +! day n to time 0100 on day n + 1 for all n. + +logical :: repeat_alarm +type(time_type), intent(in) :: time, alarm_frequency, alarm_length +type(time_type) :: prev, next + +prev = (time / alarm_frequency) * alarm_frequency +next = prev + alarm_frequency +if(time - prev <= alarm_length / 2 .or. next - time <= alarm_length / 2) then + repeat_alarm = .TRUE. +else + repeat_alarm = .FALSE. +endif + +end function repeat_alarm +! + +!-------------------------------------------------------------------------- + +!========================================================================= +! CALENDAR OPERATIONS BEGIN HERE +!========================================================================= + +! + +! +! Sets the default calendar type for mapping time intervals to dates. +! +! +! A constant number for setting the calendar type. +! +! + +! +! A constant number for setting the calendar type. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! + +subroutine set_calendar_type(type, err_msg) + +! Selects calendar for default mapping from time to date. + +integer, intent(in) :: type +character(len=*), intent(out), optional :: err_msg +integer :: iday, days_this_month, year, month, day +logical :: leap +character(len=256) :: err_msg_local + +if(.not.module_is_initialized) call time_manager_init() + +if(present(err_msg)) err_msg = '' + +if(type < 0 .or. type > max_type) then + err_msg_local = 'Illegal calendar type' + if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return +endif + +if(seconds_per_day /= 86400 .and. type /= NO_CALENDAR ) then + err_msg_local = 'Only calendar type NO_CALENDAR is allowed when seconds_per_day is not 86400.'// & + ' You are using '//trim(valid_calendar_types(type))//' and seconds_per_day=' + write(err_msg_local(len_trim(err_msg_local)+1:len_trim(err_msg_local)+8),'(i8)') seconds_per_day + if(error_handler('subroutine set_calendar_type', err_msg_local, err_msg)) return +endif + +calendar_type = type + +if(type == GREGORIAN) then + date_to_day = invalid_date + iday = 0 + do year=1,400 + leap = leap_year_gregorian_int(year) + do month=1,12 + days_this_month = days_per_month(month) + if(leap .and. month ==2) days_this_month = 29 + do day=1,days_this_month + date_to_day(year,month,day) = iday + iday = iday+1 + coded_date(iday) = day + 32*(month + 16*year) + enddo ! do day + enddo ! do month + enddo ! do year +endif + +end subroutine set_calendar_type +! + +!------------------------------------------------------------------------ +! + +! +! Returns the value of the default calendar type for mapping +! from time to date. +! +! +! There are no arguments in this function. It returns the value of +! the default calendar type for mapping from time to date. +! +! + +function get_calendar_type() + +! Returns default calendar type for mapping from time to date. + +integer :: get_calendar_type + +get_calendar_type = calendar_type + +end function get_calendar_type +! + +!------------------------------------------------------------------------ +! + +! +! Sets the number of ticks per second. +! +! +! Sets the number of ticks per second. +! +! +! + +subroutine set_ticks_per_second(tps) +integer, intent(in) :: tps + +ticks_per_second = tps + +end subroutine set_ticks_per_second + +! + +!------------------------------------------------------------------------ +! + +! +! Returns the number of ticks per second. +! +! +! Returns the number of ticks per second. +! +! + +function get_ticks_per_second() +integer :: get_ticks_per_second + +get_ticks_per_second = ticks_per_second + +end function get_ticks_per_second + +! +!------------------------------------------------------------------------ + +!======================================================================== +! START OF get_date BLOCK +! + +! +! Given a time_interval, returns the corresponding date under +! the selected calendar. +! +! +! Given a time_interval, returns the corresponding date under +! the selected calendar. +! +! +! A time interval. +! +! +! +! +! +! +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! + subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg) + +! Given a time, computes the corresponding date given the selected calendar + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer, intent(out), optional :: tick + character(len=*), intent(out), optional :: err_msg + character(len=128) :: err_msg_local + integer :: tick1 + + if(.not.module_is_initialized) call time_manager_init + if(present(err_msg)) err_msg = '' + + select case(calendar_type) + case(THIRTY_DAY_MONTHS) + call get_date_thirty (time, year, month, day, hour, minute, second, tick1) + case(GREGORIAN) + call get_date_gregorian(time, year, month, day, hour, minute, second, tick1) + case(JULIAN) + call get_date_julian_private (time, year, month, day, hour, minute, second, tick1) + case(NOLEAP) + call get_date_no_leap_private (time, year, month, day, hour, minute, second, tick1) + case(NO_CALENDAR) + err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR' + if(error_handler('subroutine get_date', err_msg_local, err_msg)) return + case default + err_msg_local = 'Invalid calendar type' + if(error_handler('subroutine get_date', err_msg_local, err_msg)) return + end select + + if(present(tick)) then + tick = tick1 + else + if(tick1 /= 0) then + err_msg_local = 'tick must be present when time has a second fraction' + if(error_handler('subroutine get_date', err_msg_local, err_msg)) return + endif + endif + + end subroutine get_date +! +!------------------------------------------------------------------------ + + subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick) + +! Computes date corresponding to time for gregorian calendar + + type(time_type), intent(in) :: time + integer, intent(out) :: year, month, day, hour, minute, second + integer, intent(out) :: tick + integer :: iday, isec + + if(Time%seconds >= 86400) then ! This check appears to be unecessary. + call error_mesg('get_date','Time%seconds .ge. 86400 in subroutine get_date_gregorian',FATAL) + endif + + iday = mod(Time%days+1,days_in_400_year_period) + if(iday == 0) iday = days_in_400_year_period + + year = coded_date(iday)/512 + day = mod(coded_date(iday),32) + month = coded_date(iday)/32 - 16*year + + year = year + 400*((Time%days)/days_in_400_year_period) + + hour = Time%seconds / 3600 + isec = Time%seconds - 3600*hour + minute = isec / 60 + second = isec - 60*minute + tick = time%ticks + + end subroutine get_date_gregorian + +!------------------------------------------------------------------------ + function cut0(string) + character(len=256) :: cut0 + character(len=*), intent(in) :: string + integer :: i + + cut0 = string + + do i=1,len(string) + if(ichar(string(i:i)) == 0 ) then + cut0(i:i) = ' ' + endif + enddo + + return + end function cut0 +!------------------------------------------------------------------------ + + subroutine get_date_julian_private(time, year, month, day, hour, minute, second, tick) + +! Base date for Julian calendar is year 1 with all multiples of 4 +! years being leap years. + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer, intent(out) :: tick + integer :: m, t, nfour, nex, days_this_month + logical :: leap + +! find number of four year periods; also get modulo number of days + nfour = time%days / (4 * 365 + 1) + day = modulo(time%days, (4 * 365 + 1)) + +! Find out what year in four year chunk + nex = day / 365 + if(nex == 4) then + nex = 3 + day = 366 + else + day=modulo(day, 365) + 1 + endif + +! Is this a leap year? + leap = (nex == 3) + + year = 1 + 4 * nfour + nex + +! find month and day + do m = 1, 12 + month = m + days_this_month = days_per_month(m) + if(leap .and. m == 2) days_this_month = 29 + if(day <= days_this_month) exit + day = day - days_this_month + end do + +! find hour,minute and second + t = time%seconds + hour = t / (60 * 60) + t = t - hour * (60 * 60) + minute = t / 60 + second = t - 60 * minute + tick = time%ticks + end subroutine get_date_julian_private + +!------------------------------------------------------------------------ + subroutine get_date_julian(time, year, month, day, hour, minute, second) + +! No need to include tick in argument list because this routine +! exists only for interpolator.F90, which does not need it. + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer :: tick + + call get_date_julian_private(time, year, month, day, hour, minute, second, tick) + + end subroutine get_date_julian + +!------------------------------------------------------------------------ + + subroutine get_date_thirty(time, year, month, day, hour, minute, second, tick) + +! Computes date corresponding to time interval for 30 day months, 12 +! month years. + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer, intent(out) :: tick + integer :: t, dmonth, dyear + + t = time%days + dyear = t / (30 * 12) + year = dyear + 1 + t = t - dyear * (30 * 12) + dmonth = t / 30 + month = 1 + dmonth + day = t -dmonth * 30 + 1 + + t = time%seconds + hour = t / (60 * 60) + t = t - hour * (60 * 60) + minute = t / 60 + second = t - 60 * minute + tick = time%ticks + + end subroutine get_date_thirty +!------------------------------------------------------------------------ + + subroutine get_date_no_leap_private(time, year, month, day, hour, minute, second, tick) + +! Base date for NOLEAP calendar is year 1. + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer, intent(out) :: tick + integer :: m, t + +! get modulo number of days + year = time%days / 365 + 1 + day = modulo(time%days, 365) + 1 + +! find month and day + do m = 1, 12 + month = m + if(day <= days_per_month(m)) exit + day = day - days_per_month(m) + end do + +! find hour,minute and second + t = time%seconds + hour = t / (60 * 60) + t = t - hour * (60 * 60) + minute = t / 60 + second = t - 60 * minute + tick = time%ticks + + end subroutine get_date_no_leap_private + +!------------------------------------------------------------------------ + subroutine get_date_no_leap(time, year, month, day, hour, minute, second) + +! No need to include tick in argument list because this routine +! exists only for interpolator.F90, which does not need it. + + type(time_type), intent(in) :: time + integer, intent(out) :: second, minute, hour, day, month, year + integer :: tick + + call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick) + + end subroutine get_date_no_leap +!------------------------------------------------------------------------ + +! END OF get_date BLOCK +!======================================================================== +! START OF set_date BLOCK +! + +! +! Given an input date in year, month, days, etc., creates a +! time_type that represents this time interval from the +! internally defined base date. +! +! +! Given a date, computes the corresponding time given the selected +! date time mapping algorithm. Note that it is possible to specify +! any number of illegal dates; these should be checked for and generate +! errors as appropriate. +! +! +! +! A time interval. +! +! +! +! +! +! +! +! +! If the year number is zero, it will be silently changed to one, +! unless zero_year_warning=.true., in which case a WARNING message +! will also be issued. +! +! +! When .true., any fractions of a second will be rounded off to the nearest tick. +! When .false., it is a fatal error if the second fraction cannot be exactly +! represented by a number of ticks. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! A time interval. + + function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg) + +! Given a date, computes the corresponding time given the selected +! date time mapping algorithm. Note that it is possible to specify +! any number of illegal dates; these are checked for and generate +! errors as appropriate. + + logical :: set_date_private + integer, intent(in) :: year, month, day, hour, minute, second, tick + type(time_type) :: Time_out + character(len=*), intent(out) :: err_msg + + if(.not.module_is_initialized) call time_manager_init + + err_msg = '' + + select case(calendar_type) + case(THIRTY_DAY_MONTHS) + set_date_private = set_date_thirty (year, month, day, hour, minute, second, tick, Time_out, err_msg) + case(GREGORIAN) + set_date_private = set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg) + case(JULIAN) + set_date_private = set_date_julian_private (year, month, day, hour, minute, second, tick, Time_out, err_msg) + case(NOLEAP) + set_date_private = set_date_no_leap_private (year, month, day, hour, minute, second, tick, Time_out, err_msg) + case (NO_CALENDAR) + err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR' + set_date_private = .false. + case default + err_msg = 'Invalid calendar type' + set_date_private = .false. + end select + + end function set_date_private +! + +!------------------------------------------------------------------------ + function set_date_i(year, month, day, hour, minute, second, tick, err_msg) + type(time_type) :: set_date_i + integer, intent(in) :: day, month, year + integer, intent(in), optional :: second, minute, hour, tick + character(len=*), intent(out), optional :: err_msg + integer :: osecond, ominute, ohour, otick + character(len=128) :: err_msg_local + + if(.not.module_is_initialized) call time_manager_init + if(present(err_msg)) err_msg = '' + +! Missing optionals are set to 0 + osecond = 0; if(present(second)) osecond = second + ominute = 0; if(present(minute)) ominute = minute + ohour = 0; if(present(hour)) ohour = hour + otick = 0; if(present(tick)) otick = tick + + if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local)) then + if(error_handler('function set_date_i', err_msg_local, err_msg)) return + endif + + end function set_date_i +!------------------------------------------------------------------------ + + function set_date_c(string, zero_year_warning, err_msg, allow_rounding) + + ! Examples of acceptable forms of string: + + ! 1980-01-01 00:00:00 + ! 1980-01-01 00:00:00.50 + ! 1980-1-1 0:0:0 + ! 1980-1-1 + + ! year number must occupy 4 spaces. + ! months, days, hours, minutes, seconds may occupy 1 or 2 spaces + ! year, month and day must be separated by a '-' + ! hour, minute, second must be separated by a ':' + ! hour, minute, second are optional. If not present then zero is assumed. + ! second may be a real number. + + ! zero_year_warning: + ! If the year number is zero, it will be silently changed to one, + ! unless zero_year_warning=.true., in which case a WARNING message + ! will also be issued + + type(time_type) :: set_date_c + character(len=*), intent(in) :: string + logical, intent(in), optional :: zero_year_warning + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: allow_rounding + character(len=4) :: formt='(i )' + logical :: correct_form, zero_year_warning_local, allow_rounding_local + integer :: i1, i2, i3, i4, i5, i6, i7 + character(len=32) :: string_sifted_left + integer :: year, month, day, hour, minute, second, tick + character(len=128) :: err_msg_local + + if(.not.module_is_initialized) call time_manager_init() + if(present(err_msg)) err_msg = '' + if(present(zero_year_warning)) then + zero_year_warning_local = zero_year_warning + else + zero_year_warning_local = .true. + endif + if(present(allow_rounding)) then + allow_rounding_local = allow_rounding + else + allow_rounding_local = .true. + endif + + string_sifted_left = adjustl(string) + i1 = index(string_sifted_left,'-') + i2 = index(string_sifted_left,'-',back=.true.) + i3 = index(string_sifted_left,':') + i4 = index(string_sifted_left,':',back=.true.) + i5 = len_trim(cut0(string_sifted_left)) + i6 = index(string_sifted_left,'.',back=.true.) + correct_form = (i1 > 1) ! year number must occupy at least 1 space + correct_form = correct_form .and. (i2-i1 == 2 .or. i2-i1 == 3) ! month number must occupy 1 or 2 spaces + if(.not.correct_form) then + err_msg_local = 'Form of character time stamp is incorrect. The character time stamp is: '//trim(string) + if(error_handler('function set_date_c', err_msg_local, err_msg)) return + endif + write(formt(3:3),'(i1)') i1-1 + read(string_sifted_left(1:i1-1),formt) year + if(year == 0) then + year = 1 + if(zero_year_warning_local) then + call error_mesg('set_date_c','Year zero is invalid. Resetting year to 1', WARNING) + endif + endif + write(formt(3:3),'(i1)') i2-i1-1 + read(string_sifted_left(i1+1:i2-1),formt) month + i7 = min(i2+2,i5) + read(string_sifted_left(i2+1:i7),'(i2)') day + + if(i3 == 0) then +! There are no minutes or seconds in the string + minute = 0 + second = 0 + tick = 0 + if(i5 <= i2+2) then + ! There is no clocktime in the string at all + hour = 0 + else + ! The clocktime includes only hours + read(string_sifted_left(i5-1:i5),'(i2)') hour + endif + else if(i3 == i4) then + ! The string includes hours and minutes, but no seconds + read(string_sifted_left(i3-2:i3-1),'(i2)') hour + write(formt(3:3),'(i1)') i5-i3 + read(string_sifted_left(i3+1:i5),formt) minute + second = 0 + tick = 0 + else + ! The string includes hours, minutes, and seconds + read(string_sifted_left(i3-2:i3-1),'(i2)') hour + write(formt(3:3),'(i1)') i4-i3-1 + read(string_sifted_left(i3+1:i4-1),formt) minute + write(formt(3:3),'(i1)') i5-i4 + if(i6 == 0) then + ! There are no fractional seconds + read(string_sifted_left(i4+1:i5),formt) second + tick = 0 + else + read(string_sifted_left(i4+1:i6-1),formt) second + if(.not.get_tick_from_string(string_sifted_left(i6:i5), err_msg_local, allow_rounding_local, tick)) then + if(error_handler('function set_date_c', err_msg_local, err_msg)) return + endif + ! If tick has been rounded up to ticks_per_second, then bump up second. + if(tick == ticks_per_second) then + second = second + 1 + tick = 0 + endif + endif + endif + + if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local)) then + if(error_handler('function set_date_c', err_msg_local, err_msg)) return + endif + + end function set_date_c +!------------------------------------------------------------------------ + + function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg) + logical :: set_date_gregorian + +! Computes time corresponding to date for gregorian calendar. + + integer, intent(in) :: year, month, day, hour, minute, second, tick + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + integer :: yr1, day1 + + if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then + set_date_gregorian = .false. + return + endif + + Time_out%seconds = second + 60*(minute + 60*hour) + + yr1 = mod(year,400) + if(yr1 == 0) yr1 = 400 + day1 = date_to_day(yr1,month,day) + if(day1 == invalid_date) then + err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_gregorian = .false. + return + endif + + Time_out%days = day1 + days_in_400_year_period*((year-1)/400) + Time_out%ticks = tick + err_msg = '' + set_date_gregorian = .true. + + end function set_date_gregorian + +!------------------------------------------------------------------------ + + function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg) + logical :: set_date_julian_private + +! Returns time corresponding to date for julian calendar. + + integer, intent(in) :: year, month, day, hour, minute, second, tick + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + integer :: ndays, m, nleapyr + logical :: leap + + if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then + set_date_julian_private = .false. + return + endif + + if(month /= 2 .and. day > days_per_month(month)) then + err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_julian_private = .false. + return + endif + +! Is this a leap year? + leap = (modulo(year,4) == 0) +! compute number of complete leap years from year 1 + nleapyr = (year - 1) / 4 + +! Finish checking for day specication errors + if(month == 2 .and. (day > 29 .or. ((.not. leap) .and. day > 28))) then + err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_julian_private = .false. + return + endif + + ndays = 0 + do m = 1, month - 1 + ndays = ndays + days_per_month(m) + if(leap .and. m == 2) ndays = ndays + 1 + enddo + + Time_out%seconds = second + 60 * (minute + 60 * hour) + Time_out%days = day -1 + ndays + 365*(year - nleapyr - 1) + 366*(nleapyr) + Time_out%ticks = tick + err_msg = '' + set_date_julian_private = .true. + + end function set_date_julian_private + +!------------------------------------------------------------------------ + function set_date_julian(year, month, day, hour, minute, second) + +! No need to include tick or err_msg in argument list because this +! routine exists only for interpolator.F90, which does not need them. + + type(time_type) :: set_date_julian + integer, intent(in) :: year, month, day, hour, minute, second + character(len=128) :: err_msg + + if(.not.set_date_julian_private(year, month, day, hour, minute, second, 0, set_date_julian, err_msg)) then + call error_mesg('set_date_julian',trim(err_msg),FATAL) + endif + + end function set_date_julian +!------------------------------------------------------------------------ + + function set_date_thirty(year, month, day, hour, minute, second, tick, Time_out, err_msg) + logical :: set_date_thirty + +! Computes time corresponding to date for thirty day months. + + integer, intent(in) :: year, month, day, hour, minute, second, tick + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + + if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then + set_date_thirty = .false. + return + endif + + if(day > 30) then + err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_thirty = .false. + return + endif + + Time_out%days = (day - 1) + 30 * ((month - 1) + 12 * (year - 1)) + Time_out%seconds = second + 60 * (minute + 60 * hour) + Time_out%ticks = tick + err_msg = '' + set_date_thirty = .true. + + end function set_date_thirty + +!------------------------------------------------------------------------ + + function set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg) + logical :: set_date_no_leap_private + +! Computes time corresponding to date for fixed 365 day year calendar. + + integer, intent(in) :: year, month, day, hour, minute, second, tick + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + integer :: ndays, m + + if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then + set_date_no_leap_private = .false. + return + endif + + if(day > days_per_month(month)) then + err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_no_leap_private = .false. + return + endif + + ndays = 0 + do m = 1, month - 1 + ndays = ndays + days_per_month(m) + enddo + +! No need for err_msg in call to set_time because previous checks ensure positive value of time. + Time_out = set_time(second + 60 * (minute + 60 * hour), day -1 + ndays + 365 * (year - 1), tick) + err_msg = '' + set_date_no_leap_private = .true. + + end function set_date_no_leap_private +!------------------------------------------------------------------------ + + function set_date_no_leap(year, month, day, hour, minute, second) + +! No need to include tick or err_msg in argument list because this +! routine exists only for interpolator.F90, which does not need them. + + type(time_type) :: set_date_no_leap + integer, intent(in) :: year, month, day, hour, minute, second + character(len=128) :: err_msg + + if(.not.set_date_no_leap_private(year, month, day, hour, minute, second, 0, set_date_no_leap, err_msg)) then + call error_mesg('set_date_no_leap',trim(err_msg),FATAL) + endif + + end function set_date_no_leap + +!========================================================================= + + function valid_increments(year, month, day, hour, minute, second, tick, err_msg) + logical :: valid_increments + integer, intent(in) :: year, month, day, hour, minute, second, tick + character(len=128), intent(out) :: err_msg + +! Check for invalid values + + err_msg = '' + valid_increments = .true. + if(second > 59 .or. second < 0 .or. minute > 59 .or. minute < 0 & + .or. hour > 23 .or. hour < 0 .or. day > 31 .or. day < 1 & + .or. month > 12 .or. month < 1 .or. year < 1) then + err_msg = 'Invalid date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + valid_increments = .false. + return + endif + if(tick < 0 .or. tick >= ticks_per_second) then + write(err_msg,'(a,i6)') 'Invalid number of ticks. tick=',tick + valid_increments = .false. + endif + + end function valid_increments + +!========================================================================= + + function convert_integer_date_to_char(year, month, day, hour, minute, second) + character(len=19) :: convert_integer_date_to_char + integer, intent(in) :: year, month, day + integer, intent(in) :: hour, minute, second + + write(convert_integer_date_to_char,10) year,month,day,hour,minute,second + 10 format(i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2) + + end function convert_integer_date_to_char + +!========================================================================= +! END OF set_date BLOCK +!========================================================================= + +! + +! +! Increments the date represented by a time interval and the +! default calendar type by a number of seconds, etc. +! +! +! Given a time and some date increment, computes a new time. Depending +! on the mapping algorithm from date to time, it may be possible to specify +! undefined increments (i.e. if one increments by 68 days and 3 months in +! a Julian calendar, it matters which order these operations are done and +! we don't want to deal with stuff like that, make it an error). +! +! +! A time interval. +! An increment of years. +! An increment of months. +! An increment of days. +! An increment of hours. +! An increment of minutes. +! An increment of seconds. +! An increment of ticks. +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! A new time based on the input +! time interval and the calendar type. +! +! +! When .false., it is a fatal error if any of the input time increments are negative. +! This mimics the behavior of lima and earlier revisions. +! +! +! For all but the thirty_day_months calendar, increments to months +! and years must be made separately from other units because of the +! non-associative nature of addition. +! If the result is a negative time (i.e. date before the base date) +! it is considered a fatal error. +! + + function increment_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc) + +! Given a time and some date increment, computes a new time. Depending +! on the mapping algorithm from date to time, it may be possible to specify +! undefined increments (i.e. if one increments by 68 days and 3 months in +! a Julian calendar, it matters which order these operations are done and +! we don't want to deal with stuff like that, make it an error). + +! This routine operates in one of two modes. +! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments. +! 2. years and/or months are incremented, other time increments must be zero or absent arguments. + + type(time_type) :: increment_date + type(time_type), intent(in) :: Time + integer, intent(in), optional :: years, months, days, hours, minutes, seconds, ticks + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: allow_neg_inc + + integer :: oyears, omonths, odays, ohours, ominutes, oseconds, oticks + character(len=128) :: err_msg_local + logical :: allow_neg_inc_local + + if(.not.module_is_initialized) call time_manager_init + if(present(err_msg)) err_msg = '' + +! Missing optionals are set to 0 + oseconds = 0; if(present(seconds)) oseconds = seconds + ominutes = 0; if(present(minutes)) ominutes = minutes + ohours = 0; if(present(hours)) ohours = hours + odays = 0; if(present(days)) odays = days + omonths = 0; if(present(months)) omonths = months + oyears = 0; if(present(years)) oyears = years + oticks = 0; if(present(ticks)) oticks = ticks + allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc + + if(.not.allow_neg_inc_local) then + if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then + write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks + if(error_handler('function increment_time', err_msg_local, err_msg)) return + endif + endif + 10 format('One or more time increments are negative: '// & + 'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6) + + if(.not.increment_date_private( & + Time, oyears, omonths, odays, ohours, ominutes, oseconds, oticks, increment_date, err_msg_local)) then + if(error_handler('function increment_date', err_msg_local, err_msg)) return + endif + + end function increment_date + +! + +!======================================================================= + + function increment_date_private(Time, years, months, days, hours, minutes, seconds, ticks, Time_out, err_msg) + +! Given a time and some date increment, computes a new time. Depending +! on the mapping algorithm from date to time, it may be possible to specify +! undefined increments (i.e. if one increments by 68 days and 3 months in +! a Julian calendar, it matters which order these operations are done and +! we don't want to deal with stuff like that, make it an error). + +! This routine operates in one of two modes. +! 1. days, hours, minutes, seconds, ticks are incremented, years and months must be zero or absent arguments. +! 2. years and/or months are incremented, other time increments must be zero or absent arguments. + +! Negative increments are always allowed in the private version of this routine. + + logical :: increment_date_private + type(time_type), intent(in) :: Time + integer, intent(in) :: years, months, days, hours, minutes, seconds, ticks + type(time_type), intent(out) :: Time_out + character(len=*), intent(out) :: err_msg + integer :: cyear , cmonth , cday , chour , cminute , csecond , ctick + logical :: mode_1, mode_2 + + err_msg = '' + increment_date_private = .true. + + mode_1 = days /= 0 .or. hours /= 0 .or. minutes /= 0 .or. seconds /= 0 .or. ticks /= 0 + mode_2 = years /= 0 .or. months /= 0 + + if(.not.mode_1 .and. .not.mode_2) then + ! All time increments are zero + Time_out = Time + return + endif + + if(mode_1 .and. mode_2) then + err_msg = 'years and/or months must not be incremented with other time units' + increment_date_private = .false. + return + endif + + if(mode_1) then + csecond = seconds + 60 * (minutes + 60 * hours) + increment_date_private = increment_time_private(Time, csecond, days, ticks, Time_out, err_msg) + endif + + if(mode_2) then + ! Convert Time to a date + select case(calendar_type) + case(THIRTY_DAY_MONTHS) + call get_date_thirty (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick) + case(NOLEAP) + call get_date_no_leap_private (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick) + case(JULIAN) + call get_date_julian_private (Time, cyear, cmonth, cday, chour, cminute, csecond, ctick) + case(GREGORIAN) + call get_date_gregorian(Time, cyear, cmonth, cday, chour, cminute, csecond, ctick) + case(NO_CALENDAR) + err_msg = 'Cannot increment a date when the calendar type is NO_CALENDAR' + increment_date_private = .false. + return + case default + err_msg = 'Invalid calendar type' + increment_date_private = .false. + return + end select + + ! Add month increment + cmonth = cmonth + months + + ! Adjust year and month number when cmonth falls outside the range 1 to 12 + cyear = cyear + floor((cmonth-1)/12.) + cmonth = modulo((cmonth-1),12) + 1 + + ! Add year increment + cyear = cyear + years + + ! Convert this back into a time. + select case(calendar_type) + case(THIRTY_DAY_MONTHS) + increment_date_private = set_date_thirty (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg) + case(NOLEAP) + increment_date_private = set_date_no_leap_private (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg) + case(JULIAN) + increment_date_private = set_date_julian_private (cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg) + case(GREGORIAN) + increment_date_private = set_date_gregorian(cyear, cmonth, cday, chour, cminute, csecond, ctick, Time_out, err_msg) + end select + endif ! if(mode_2) + + end function increment_date_private + +!========================================================================= +! + +! +! Decrements the date represented by a time interval and the +! default calendar type by a number of seconds, etc. +! +! +! Given a time and some date decrement, computes a new time. Depending +! on the mapping algorithm from date to time, it may be possible to specify +! undefined decrements (i.e. if one decrements by 68 days and 3 months in +! a Julian calendar, it matters which order these operations are done and +! we don't want to deal with stuff like that, make it an error). +! +! +! A time interval. +! An decrement of years. +! An decrement of months. +! An decrement of days. +! An decrement of hours. +! An decrement of minutes. +! An decrement of seconds. +! An decrement of ticks. +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! A new time based on the input +! time interval and the calendar type. +! +! +! When .false., it is a fatal error if any of the input time increments are negative. +! This mimics the behavior of lima and earlier revisions. +! +! +! For all but the thirty_day_months calendar, decrements to months +! and years must be made separately from other units because of the +! non-associative nature of addition. +! If the result is a negative time (i.e. date before the base date) +! it is considered a fatal error. +! + + function decrement_date(Time, years, months, days, hours, minutes, seconds, ticks, err_msg, allow_neg_inc) + + type(time_type) :: decrement_date + type(time_type), intent(in) :: Time + integer, intent(in), optional :: seconds, minutes, hours, days, months, years, ticks + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: allow_neg_inc + + integer :: oseconds, ominutes, ohours, odays, omonths, oyears, oticks + character(len=128) :: err_msg_local + logical :: allow_neg_inc_local + + if(present(err_msg)) err_msg = '' + + ! Missing optionals are set to 0 + oseconds = 0; if(present(seconds)) oseconds = seconds + ominutes = 0; if(present(minutes)) ominutes = minutes + ohours = 0; if(present(hours)) ohours = hours + odays = 0; if(present(days)) odays = days + omonths = 0; if(present(months)) omonths = months + oyears = 0; if(present(years)) oyears = years + oticks = 0; if(present(ticks)) oticks = ticks + allow_neg_inc_local=.true.; if(present(allow_neg_inc)) allow_neg_inc_local=allow_neg_inc + + if(.not.allow_neg_inc_local) then + if(oyears < 0 .or. omonths < 0 .or. odays < 0 .or. ohours < 0 .or. ominutes < 0 .or. oseconds < 0 .or. oticks < 0) then + write(err_msg_local,10) oyears, omonths, odays, ohours, ominutes, oseconds, oticks + if(error_handler('function decrement_date', err_msg_local, err_msg)) return + endif + endif + 10 format('One or more time increments are negative: '// & + 'years=',i6,' months=',i6,' days=',i6,' hours=',i6,' minutes=',i6,' seconds=',i6,' ticks=',i6) + + if(.not.increment_date_private( & + Time, -oyears, -omonths, -odays, -ohours, -ominutes, -oseconds, -oticks, decrement_date, err_msg_local)) then + if(error_handler('function decrement_date', err_msg_local, err_msg)) return + endif + + end function decrement_date + ! + +!========================================================================= +! START days_in_month BLOCK +! + +! +! Given a time interval, gives the number of days in the +! month corresponding to the default calendar. +! +! +! Given a time, computes the corresponding date given the selected +! date time mapping algorithm. +! +! + +! A time interval. +! +! The number of days in the month given the selected time +! mapping algorithm. +! + +function days_in_month(Time, err_msg) + +! Given a time, computes the corresponding date given the selected +! date time mapping algorithm + +integer :: days_in_month +type(time_type), intent(in) :: Time +character(len=*), intent(out), optional :: err_msg + +if(.not.module_is_initialized) call time_manager_init +if(present(err_msg)) err_msg = '' + +select case(calendar_type) +case(THIRTY_DAY_MONTHS) + days_in_month = days_in_month_thirty(Time) +case(GREGORIAN) + days_in_month = days_in_month_gregorian(Time) +case(JULIAN) + days_in_month = days_in_month_julian(Time) +case(NOLEAP) + days_in_month = days_in_month_no_leap(Time) +case(NO_CALENDAR) + if(error_handler('function days_in_month', & + 'days_in_month makes no sense when the calendar type is NO_CALENDAR', err_msg)) return +case default + if(error_handler('function days_in_month', 'Invalid calendar type', err_msg)) return +end select +end function days_in_month +! + +!-------------------------------------------------------------------------- + +function days_in_month_gregorian(Time) + +! Returns the number of days in a gregorian month. + +integer :: days_in_month_gregorian +type(time_type), intent(in) :: Time +integer :: year, month, day, hour, minute, second, ticks + +call get_date_gregorian(Time, year, month, day, hour, minute, second, ticks) +days_in_month_gregorian = days_per_month(month) +if(leap_year_gregorian_int(year) .and. month == 2) days_in_month_gregorian = 29 + +end function days_in_month_gregorian + +!-------------------------------------------------------------------------- +function days_in_month_julian(Time) + +! Returns the number of days in a julian month. + +integer :: days_in_month_julian +type(time_type), intent(in) :: Time +integer :: year, month, day, hour, minute, second, ticks + +call get_date_julian_private(Time, year, month, day, hour, minute, second, ticks) +days_in_month_julian = days_per_month(month) +if(leap_year_julian(Time) .and. month == 2) days_in_month_julian = 29 + +end function days_in_month_julian + +!-------------------------------------------------------------------------- +function days_in_month_thirty(Time) + +! Returns the number of days in a thirty day month (needed for transparent +! changes to calendar type). + +integer :: days_in_month_thirty +type(time_type), intent(in) :: Time + +days_in_month_thirty = 30 + +end function days_in_month_thirty + +!-------------------------------------------------------------------------- +function days_in_month_no_leap(Time) + +! Returns the number of days in a 365 day year month. + +integer :: days_in_month_no_leap +type(time_type), intent(in) :: Time +integer :: year, month, day, hour, minute, second, ticks + +call get_date_no_leap_private(Time, year, month, day, hour, minute, second, ticks) +days_in_month_no_leap= days_per_month(month) + +end function days_in_month_no_leap + +! END OF days_in_month BLOCK +!========================================================================== +! START OF leap_year BLOCK +! + +! +! Returns true if the year corresponding to the input time is +! a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP. +! +! +! Returns true if the year corresponding to the input time is +! a leap year. Always returns false for THIRTY_DAY_MONTHS and NOLEAP. +! +! + +! A time interval. +! +! true if the year corresponding to the input time is a leap year. +! + +function leap_year(Time, err_msg) + +! Is this date in a leap year for default calendar? + +logical :: leap_year +type(time_type), intent(in) :: Time +character(len=*), intent(out), optional :: err_msg + +if(.not.module_is_initialized) call time_manager_init +if(present(err_msg)) err_msg='' + +select case(calendar_type) +case(THIRTY_DAY_MONTHS) + leap_year = leap_year_thirty(Time) +case(GREGORIAN) + leap_year = leap_year_gregorian(Time) +case(JULIAN) + leap_year = leap_year_julian(Time) +case(NOLEAP) + leap_year = leap_year_no_leap(Time) +case default + if(error_handler('function leap_year', 'Invalid calendar type in leap_year', err_msg)) return +end select +end function leap_year +! + +!-------------------------------------------------------------------------- + +function leap_year_gregorian(Time) + +! Is this a leap year for gregorian calendar? + +logical :: leap_year_gregorian +type(time_type), intent(in) :: Time +integer :: seconds, minutes, hours, day, month, year + +call get_date(Time, year, month, day, hours, minutes, seconds) +leap_year_gregorian = leap_year_gregorian_int(year) + +end function leap_year_gregorian + +!-------------------------------------------------------------------------- + +function leap_year_gregorian_int(year) +logical :: leap_year_gregorian_int +integer, intent(in) :: year + +leap_year_gregorian_int = mod(year,4) == 0 +leap_year_gregorian_int = leap_year_gregorian_int .and. .not.mod(year,100) == 0 +leap_year_gregorian_int = leap_year_gregorian_int .or. mod(year,400) == 0 + +end function leap_year_gregorian_int + +!-------------------------------------------------------------------------- + +function leap_year_julian(Time) + +! Returns the number of days in a julian month. + +logical :: leap_year_julian +type(time_type), intent(in) :: Time +integer :: seconds, minutes, hours, day, month, year + +call get_date(Time, year, month, day, hours, minutes, seconds) +leap_year_julian = ((year / 4 * 4) == year) + +end function leap_year_julian + +!-------------------------------------------------------------------------- + +function leap_year_thirty(Time) + +! No leap years in thirty day months, included for transparency. + +logical :: leap_year_thirty +type(time_type), intent(in) :: Time + +leap_year_thirty = .FALSE. + +end function leap_year_thirty + +!-------------------------------------------------------------------------- + +function leap_year_no_leap(Time) + +! Another tough one; no leap year returns false for leap year inquiry. + +logical :: leap_year_no_leap +type(time_type), intent(in) :: Time + +leap_year_no_leap = .FALSE. + +end function leap_year_no_leap + +!END OF leap_year BLOCK +!========================================================================== +! START OF length_of_year BLOCK +! + +! +! Returns the mean length of the year in the default calendar setting. +! +! +! There are no arguments in this function. It returns the mean +! length of the year in the default calendar setting. +! +! + +function length_of_year() + +! What is the length of the year for the default calendar type + +type(time_type) :: length_of_year + +if(.not.module_is_initialized) call time_manager_init + +select case(calendar_type) +case(THIRTY_DAY_MONTHS) + length_of_year = length_of_year_thirty() +case(GREGORIAN) + length_of_year = length_of_year_gregorian() +case(JULIAN) + length_of_year = length_of_year_julian() +case(NOLEAP) + length_of_year = length_of_year_no_leap() +case default + call error_mesg('length_of_year','Invalid calendar type in length_of_year',FATAL) +end select +end function length_of_year +! + +!-------------------------------------------------------------------------- + +function length_of_year_thirty() + +type(time_type) :: length_of_year_thirty + +length_of_year_thirty = set_time(0, 360) + +end function length_of_year_thirty + +!--------------------------------------------------------------------------- + +function length_of_year_gregorian() + +type(time_type) :: length_of_year_gregorian +integer :: days, seconds + +days = days_in_400_year_period / 400 +seconds = 86400*(days_in_400_year_period/400. - days) +length_of_year_gregorian = set_time(seconds, days) + +end function length_of_year_gregorian + +!-------------------------------------------------------------------------- + +function length_of_year_julian() + +type(time_type) :: length_of_year_julian + +length_of_year_julian = set_time((24 / 4) * 60 * 60, 365) + +end function length_of_year_julian + +!-------------------------------------------------------------------------- + +function length_of_year_no_leap() + +type(time_type) :: length_of_year_no_leap + +length_of_year_no_leap = set_time(0, 365) + +end function length_of_year_no_leap + +!-------------------------------------------------------------------------- + +! END OF length_of_year BLOCK +!========================================================================== + +!========================================================================== +! return number of day in year; Jan 1st is day 1, not zero! +function day_of_year(time) + integer :: day_of_year + type(time_type), intent(in) :: Time + + integer :: second, minute, hour, day, month, year + type(time_type) :: t + + call get_date(time,year,month,day,hour,minute,second) + t = time-set_date(year,1,1,0,0,0) + day_of_year = t%days + 1 +end + +! START OF days_in_year BLOCK +! + +! +! Returns the number of days in the calendar year corresponding to +! the date represented by time for the default calendar. +! +! +! Returns the number of days in the calendar year corresponding to +! the date represented by time for the default calendar. +! +! +! A time interval. +! +! The number of days in this year for the default calendar type. +! + + +function days_in_year(Time) + +! What is the number of days in this year for the default calendar type + +integer :: days_in_year +type(time_type), intent(in) :: Time + +if(.not.module_is_initialized) call time_manager_init + +select case(calendar_type) +case(THIRTY_DAY_MONTHS) + days_in_year = days_in_year_thirty(Time) +case(GREGORIAN) + days_in_year = days_in_year_gregorian(Time) +case(JULIAN) + days_in_year = days_in_year_julian(Time) +case(NOLEAP) + days_in_year = days_in_year_no_leap(Time) +case default + call error_mesg('days_in_year','Invalid calendar type in days_in_year',FATAL) +end select +end function days_in_year +! + +!-------------------------------------------------------------------------- + +function days_in_year_thirty(Time) + +integer :: days_in_year_thirty +type(time_type), intent(in) :: Time + +days_in_year_thirty = 360 + +end function days_in_year_thirty + +!--------------------------------------------------------------------------- + +function days_in_year_gregorian(Time) + +integer :: days_in_year_gregorian +type(time_type), intent(in) :: Time + +if(leap_year_gregorian(Time)) then + days_in_year_gregorian = 366 +else + days_in_year_gregorian = 365 +endif + +end function days_in_year_gregorian + +!-------------------------------------------------------------------------- +function days_in_year_julian(Time) + +integer :: days_in_year_julian +type(time_type), intent(in) :: Time + +if(leap_year_julian(Time)) then + days_in_year_julian = 366 +else + days_in_year_julian = 365 +endif + +end function days_in_year_julian + +!-------------------------------------------------------------------------- + +function days_in_year_no_leap(Time) + +integer :: days_in_year_no_leap +type(time_type), intent(in) :: Time + +days_in_year_no_leap = 365 + +end function days_in_year_no_leap + +!-------------------------------------------------------------------------- + +! END OF days_in_year BLOCK + +!========================================================================== +! + +! +! Returns a character string containing the name of the +! month corresponding to month number n. +! +! +! Returns a character string containing the name of the +! month corresponding to month number n. Definition is the +! same for all calendar types. +! +! +! Month number. +! +! The character string associated with a month. +! All calendars have 12 months and return full +! month names, not abreviations. +! + +function month_name(n) + +! Returns character string associated with a month, for now, all calendars +! have 12 months and will return standard names. + +character (len=9) :: month_name +integer, intent(in) :: n +character (len = 9), dimension(12) :: months = (/'January ', 'February ', & + 'March ', 'April ', 'May ', 'June ', 'July ', & + 'August ', 'September', 'October ', 'November ', 'December '/) + +if(.not.module_is_initialized) call time_manager_init + +if(n < 1 .or. n > 12) call error_mesg('month_name','Illegal month index',FATAL) + +month_name = months(n) + +end function month_name +! + +!========================================================================== + + function error_handler(routine, err_msg_local, err_msg) + +! The purpose of this routine is to prevent the addition of an excessive amount of code in order to implement +! the error handling scheme involving an optional error flag of type character. +! It allows one line of code to accomplish what would otherwise require 6 lines. +! A value of .true. for this function is a flag to the caller that it should immediately return to it's caller. + + logical :: error_handler + character(len=*), intent(in) :: routine, err_msg_local + character(len=*), intent(out), optional :: err_msg + + error_handler = .false. + if(present(err_msg)) then + err_msg = err_msg_local + error_handler = .true. + else + call error_mesg(trim(routine),trim(err_msg_local),FATAL) + endif + + end function error_handler + +!========================================================================== +!------------------------------------------------------------------------ +! + +! +! Writes the version information to the log file +! +! +! Initialization routine. +! Writes the version information to the log file +! +! + +subroutine time_manager_init ( ) + + if (module_is_initialized) return ! silent return if already called + + call write_version_number("TIME_MANAGER_MOD", version) + module_is_initialized = .true. + +end subroutine time_manager_init +! + +!------------------------------------------------------------------------ +! + +! +! Prints the given time_type argument as a time (using days, seconds and ticks) +! +! +! Prints the given time_type argument as a time (using days, seconds and ticks) +! NOTE: there is no check for PE number. +! +! +! Time that will be printed. +! +! Character string that precedes the printed time or date. +! +! +! Unit number for printed output. The default unit is stdout. +! +subroutine print_time (Time,str,unit) +type(time_type) , intent(in) :: Time +character (len=*), intent(in), optional :: str +integer , intent(in), optional :: unit +integer :: s,d,ticks, ns,nd,nt, unit_in +character(len=19) :: fmt + +! prints the time to standard output (or optional unit) as days and seconds +! NOTE: there is no check for PE number + + unit_in = stdout() + if (present(unit)) unit_in = unit + + call get_time (Time,s,d,ticks) + +! format output +! get number of digits for days and seconds strings + nd = int(log10(real(max(1,d))))+1 + ns = int(log10(real(max(1,s))))+1 + nt = int(log10(real(max(1,ticks))))+1 + write (fmt,10) nd, ns, nt +10 format ('(a,i',i2.2,',a,i',i2.2,',a,i',i2.2,')') + + if (present(str)) then + write (unit_in,fmt) trim(str)//' day=', d, ', sec=', s, ', ticks=', ticks + else + write (unit_in,fmt) 'TIME: day=', d, ', sec=', s, ', ticks=', ticks + endif + +end subroutine print_time +! + +!------------------------------------------------------------------------ +! + +! +! prints the time to standard output (or optional unit) as a date. +! +! +! Prints the given time_type argument as a date (using year, month, day, +! hour, minutes, seconds and ticks). NOTE: there is no check for PE number. +! +! +! Time that will be printed. +! +! Character string that precedes the printed time or date. +! +! +! Unit number for printed output. The default unit is stdout. +! + +subroutine print_date (Time,str,unit) +type(time_type) , intent(in) :: Time +character (len=*), intent(in), optional :: str +integer , intent(in), optional :: unit +integer :: y,mo,d,h,m,s, unit_in +character(len=9) :: mon + +! prints the time to standard output (or optional unit) as a date +! NOTE: there is no check for PE number + + unit_in = stdout() + if (present(unit)) unit_in = unit + + call get_date (Time,y,mo,d,h,m,s) + mon = month_name(mo) + if (present(str)) then + write (unit_in,10) trim(str)//' ', y,mon(1:3),' ',d,' ',h,':',m,':',s + else + write (unit_in,10) 'DATE: ', y,mon(1:3),' ',d,' ',h,':',m,':',s + endif +10 format (a,i4,1x,a3,4(a1,i2.2)) + +end subroutine print_date +! + +!------------------------------------------------------------------------ +! + +! +! Returns a character string that describes the +! calendar type corresponding to the input integer. +! +! +! Returns a character string that describes the +! calendar type corresponding to the input integer. +! +! +! An integer corresponding to a valid calendar type. +! +! +! When present, and when non-blank, a fatal error condition as been detected. +! The string itself is an error message. +! It is recommended that, when err_msg is present in the call +! to this routine, the next line of code should be something +! similar to this: +! if(err_msg /= '') call error_mesg('my_routine','additional info: '//trim(err_msg),FATAL) +! +! +! A character string describing the calendar type. +! + +function valid_calendar_types(ncal, err_msg) +integer, intent(in) :: ncal +character(len=*), intent(out), optional :: err_msg +character(len=24) :: valid_calendar_types +character(len=128) :: err_msg_local + +if(.not.module_is_initialized) call time_manager_init + +if(present(err_msg)) err_msg = '' + +if(ncal == NO_CALENDAR) then + valid_calendar_types = 'NO_CALENDAR ' +else if(ncal == THIRTY_DAY_MONTHS) then + valid_calendar_types = '360_DAY ' +else if(ncal == JULIAN) then + valid_calendar_types = 'JULIAN ' +else if(ncal == GREGORIAN) then + valid_calendar_types = 'GREGORIAN ' +else if(ncal == NOLEAP) then + valid_calendar_types = 'NOLEAP ' +else + write(err_msg_local,'(a,i4,a)') 'calendar type=',ncal,' is invalid.' + if(error_handler('function valid_calendar_types', err_msg_local, err_msg)) return +endif +end function valid_calendar_types +! +!------------------------------------------------------------------------ + +!--- get the a character string that represents the time. The format will be +!--- yyyymmdd.hhmmss +function date_to_string(time, err_msg) + type(time_type), intent(in) :: time + character(len=*), intent(out), optional :: err_msg + character(len=128) :: err_msg_local + character(len=15) :: date_to_string + integer :: yr,mon,day,hr,min,sec + + if(present(err_msg)) err_msg = '' + call get_date(time,yr,mon,day,hr,min,sec) + if (yr <= 9999) then + write(date_to_string,'(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec + else + write(err_msg_local, '(a,i4.4,a)') 'year = ', yr, ' should be less than 10000' + if(error_handler('function date_to_string', err_msg_local, err_msg)) return + endif + +end function date_to_string + +!> \author Tom Robinson +!! \email thomas.robinson@noaa.gov +!! \brief This routine converts the integer t%days to a string +subroutine time_list_error (T,Terr) + type(time_type), intent(in) :: t !< time_type input + character(len=:), allocatable :: terr !< String holding the t%days +!> Allocate the string + allocate (character(len=10) :: terr) +!> Write the integer to the string + write (terr,'(I0)') t%days +end subroutine time_list_error + + +end module time_manager0_mod + +! + +! +! 
+!        use time_manager_mod
+!        implicit none
+!        type(time_type) :: dt, init_date, astro_base_date, time, final_date
+!        type(time_type) :: next_rad_time, mid_date
+!        type(time_type) :: repeat_alarm_freq, repeat_alarm_length
+!        integer :: num_steps, i, days, months, years, seconds, minutes, hours
+!        integer :: months2, length
+!        real :: astro_days
+!
+!   !Set calendar type
+!   !    call set_calendar_type(THIRTY_DAY_MONTHS)
+!        call set_calendar_type(JULIAN)
+!   !    call set_calendar_type(NOLEAP)
+!
+!   ! Set timestep
+!        dt = set_time(1100, 0)
+!
+!   ! Set initial date
+!        init_date = set_date(1992, 1, 1)
+!
+!   ! Set date for astronomy delta calculation
+!        astro_base_date = set_date(1970, 1, 1, 12, 0, 0)
+!
+!   ! Copy initial time to model current time
+!        time = init_date
+!
+!   ! Determine how many steps to do to run one year
+!        final_date = increment_date(init_date, years = 1)
+!        num_steps = (final_date - init_date) / dt
+!        write(*, *) 'Number of steps is' , num_steps
+!
+!   ! Want to compute radiation at initial step, then every two hours
+!        next_rad_time = time + set_time(7200, 0)
+!
+!   ! Test repeat alarm
+!        repeat_alarm_freq = set_time(0, 1)
+!        repeat_alarm_length = set_time(7200, 0)
+!
+!   ! Loop through a year
+!        do i = 1, num_steps
+!
+!   ! Increment time
+!        time = time + dt
+!
+!   ! Test repeat alarm
+!        if(repeat_alarm(time, repeat_alarm_freq, repeat_alarm_length)) &
+!        write(*, *) 'REPEAT ALARM IS TRUE'
+!
+!   ! Should radiation be computed? Three possible tests.
+!   ! First test assumes exact interval; just ask if times are equal
+!   !     if(time == next_rad_time) then
+!   ! Second test computes rad on last time step that is <= radiation time
+!   !     if((next_rad_time - time) < dt .and. time < next_rad) then
+!   ! Third test computes rad on time step closest to radiation time
+!         if(interval_alarm(time, dt, next_rad_time, set_time(7200, 0))) then
+!           call get_date(time, years, months, days, hours, minutes, seconds)
+!           write(*, *) days, month_name(months), years, hours, minutes, seconds
+!
+!   ! Need to compute real number of days between current time and astro_base
+!           call get_time(time - astro_base_date, seconds, days)
+!           astro_days = days + seconds / 86400.
+!   !       write(*, *) 'astro offset ', astro_days
+!        end if
+!
+!   ! Can compute daily, monthly, yearly, hourly, etc. diagnostics as for rad
+!
+!   ! Example: do diagnostics on last time step of this month
+!        call get_date(time + dt, years, months2, days, hours, minutes, seconds)
+!        call get_date(time, years, months, days, hours, minutes, seconds)
+!        if(months /= months2) then
+!           write(*, *) 'last timestep of month'
+!           write(*, *) days, months, years, hours, minutes, seconds
+!        endif
+!
+!   ! Example: mid-month diagnostics; inefficient to make things clear
+!        length = days_in_month(time)
+!        call get_date(time, years, months, days, hours, minutes, seconds)
+!        mid_date = set_date(years, months, 1) + set_time(0, length) / 2
+!
+!        if(time < mid_date .and. (mid_date - time) < dt) then
+!           write(*, *) 'mid-month time'
+!           write(*, *) days, months, years, hours, minutes, seconds
+!        endif
+!
+!        end do
+!
+!
+! end program time_main2 + +! +! +! The base date is implicitly defined so users don't +! need to be concerned with it. For the curious, the base date is defined as +! 0 seconds, 0 minutes, 0 hours, day 1, month 1, year 1 +! +! +! Please note that a time is a positive definite quantity. +! +! +! See the Test Program for a simple program +! that shows some of the capabilities of the time manager. +! +! diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index dec5f986f2..0ab97e6e8d 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -117,8 +117,8 @@ module time_manager_mod public get_calendar_type public set_ticks_per_second public get_ticks_per_second -public set_date, set_date2 -public get_date, get_date2 +public set_date +public get_date public increment_date public decrement_date public days_in_month @@ -157,8 +157,6 @@ module time_manager_mod integer, private :: days_per_month(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) integer, parameter :: seconds_per_day = rseconds_per_day ! This should automatically cast real to integer integer, parameter :: days_in_400_year_period = 146097 ! Used only for gregorian -integer, dimension(days_in_400_year_period) :: coded_date ! Used only for gregorian -integer, dimension(400,12,31) :: date_to_day ! Used only for gregorian integer, parameter :: invalid_date=-1 ! Used only for gregorian integer,parameter :: do_floor = 0 integer,parameter :: do_nearest = 1 @@ -200,10 +198,6 @@ module time_manager_mod module procedure set_date_i, set_date_c end interface -interface set_date2 - module procedure set_date_i2 -end interface set_date2 - !====================================================================== ! Include variable "version" to be written to log file. @@ -1552,23 +1546,6 @@ subroutine set_calendar_type(type, err_msg) calendar_type = type -if(type == GREGORIAN) then - date_to_day = invalid_date - iday = 0 - do year=1,400 - leap = leap_year_gregorian_int(year) - do month=1,12 - days_this_month = days_per_month(month) - if(leap .and. month ==2) days_this_month = 29 - do day=1,days_this_month - date_to_day(year,month,day) = iday - iday = iday+1 - coded_date(iday) = day + 32*(month + 16*year) - enddo ! do day - enddo ! do month - enddo ! do year -endif - end subroutine set_calendar_type ! @@ -1714,86 +1691,11 @@ subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg) endif end subroutine get_date -! -!:MKL - subroutine get_date2(time, year, month, day, hour, minute, second, tick, err_msg) - -! Given a time, computes the corresponding date given the selected calendar - - type(time_type), intent(in) :: time - integer, intent(out) :: second, minute, hour, day, month, year - integer, intent(out), optional :: tick - character(len=*), intent(out), optional :: err_msg - character(len=128) :: err_msg_local - integer :: tick1 - - if(.not.module_is_initialized) call time_manager_init - if(present(err_msg)) err_msg = '' - - select case(calendar_type) - case(THIRTY_DAY_MONTHS) - call get_date_thirty (time, year, month, day, hour, minute, second, tick1) - case(GREGORIAN) - call get_date_gregorian2(time, year, month, day, hour, minute, second, tick1) - case(JULIAN) - call get_date_julian_private (time, year, month, day, hour, minute, second, tick1) - case(NOLEAP) - call get_date_no_leap_private (time, year, month, day, hour, minute, second, tick1) - case(NO_CALENDAR) - err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR' - if(error_handler('subroutine get_date', err_msg_local, err_msg)) return - case default - err_msg_local = 'Invalid calendar type' - if(error_handler('subroutine get_date', err_msg_local, err_msg)) return - end select - if(present(tick)) then - tick = tick1 - else - if(tick1 /= 0) then - err_msg_local = 'tick must be present when time has a second fraction' - if(error_handler('subroutine get_date', err_msg_local, err_msg)) return - endif - endif - -end subroutine get_date2 ! - - !------------------------------------------------------------------------ - subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick) -! Computes date corresponding to time for gregorian calendar - - type(time_type), intent(in) :: time - integer, intent(out) :: year, month, day, hour, minute, second - integer, intent(out) :: tick - integer :: iday, isec - - if(Time%seconds >= 86400) then ! This check appears to be unecessary. - call error_mesg('get_date','Time%seconds .ge. 86400 in subroutine get_date_gregorian',FATAL) - endif - - iday = mod(Time%days+1,days_in_400_year_period) - if(iday == 0) iday = days_in_400_year_period - - year = coded_date(iday)/512 - day = mod(coded_date(iday),32) - month = coded_date(iday)/32 - 16*year - - year = year + 400*((Time%days)/days_in_400_year_period) - - hour = Time%seconds / 3600 - isec = Time%seconds - 3600*hour - minute = isec / 60 - second = isec - 60*minute - tick = time%ticks - - end subroutine get_date_gregorian -!:MKL - subroutine get_date_gregorian2(time, year, month, day, hour, minute, second, tick) - ! Computes date corresponding to time for gregorian calendar type(time_type), intent(in) :: time @@ -1863,7 +1765,7 @@ subroutine get_date_gregorian2(time, year, month, day, hour, minute, second, tic second = isec - 60*minute tick = time%ticks - end subroutine get_date_gregorian2 + end subroutine get_date_gregorian !------------------------------------------------------------------------ function cut0(string) @@ -2106,42 +2008,6 @@ function set_date_private(year, month, day, hour, minute, second, tick, Time_out end function set_date_private ! -!:MKL - function set_date_private2(year, month, day, hour, minute, second, tick, Time_out, err_msg) - -! Given a date, computes the corresponding time given the selected -! date time mapping algorithm. Note that it is possible to specify -! any number of illegal dates; these are checked for and generate -! errors as appropriate. - - logical :: set_date_private2 - integer, intent(in) :: year, month, day, hour, minute, second, tick - type(time_type) :: Time_out - character(len=*), intent(out) :: err_msg - - if(.not.module_is_initialized) call time_manager_init - - err_msg = '' - - select case(calendar_type) - case(THIRTY_DAY_MONTHS) - set_date_private2 = set_date_thirty (year, month, day, hour, minute, second, tick, Time_out, err_msg) - case(GREGORIAN) - set_date_private2 = set_date_gregorian2(year, month, day, hour, minute, second, tick, Time_out, err_msg) - case(JULIAN) - set_date_private2 = set_date_julian_private (year, month, day, hour, minute, second, tick, Time_out, err_msg) - case(NOLEAP) - set_date_private2 = set_date_no_leap_private (year, month, day, hour, minute, second, tick, Time_out, err_msg) - case (NO_CALENDAR) - err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR' - set_date_private2 = .false. - case default - err_msg = 'Invalid calendar type' - set_date_private2 = .false. - end select - - end function set_date_private2 - !------------------------------------------------------------------------ function set_date_i(year, month, day, hour, minute, second, tick, err_msg) type(time_type) :: set_date_i @@ -2165,31 +2031,6 @@ function set_date_i(year, month, day, hour, minute, second, tick, err_msg) endif end function set_date_i -!:MKL - function set_date_i2(year, month, day, hour, minute, second, tick, err_msg, chooseme) - type(time_type) :: set_date_i2 - integer, intent(in) :: day, month, year - integer, intent(in), optional :: second, minute, hour, tick - logical, intent(in), optional :: chooseme - character(len=*), intent(out), optional :: err_msg - integer :: osecond, ominute, ohour, otick - character(len=128) :: err_msg_local - - if(.not.module_is_initialized) call time_manager_init - if(present(err_msg)) err_msg = '' - -! Missing optionals are set to 0 - osecond = 0; if(present(second)) osecond = second - ominute = 0; if(present(minute)) ominute = minute - ohour = 0; if(present(hour)) ohour = hour - otick = 0; if(present(tick)) otick = tick - - if(.not.set_date_private2(year, month, day, ohour, ominute, osecond, otick, set_date_i2, err_msg_local)) then - if(error_handler('function set_date_i', err_msg_local, err_msg)) return - endif - - end function set_date_i2 - !------------------------------------------------------------------------ function set_date_c(string, zero_year_warning, err_msg, allow_rounding) @@ -2312,7 +2153,6 @@ function set_date_c(string, zero_year_warning, err_msg, allow_rounding) end function set_date_c !------------------------------------------------------------------------ - function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg) logical :: set_date_gregorian @@ -2322,45 +2162,29 @@ function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_o type(time_type), intent(out) :: Time_out character(len=*), intent(out) :: err_msg integer :: yr1, day1 + integer :: ncenturies, nlpyrs, l if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then set_date_gregorian = .false. return endif - Time_out%seconds = second + 60*(minute + 60*hour) - - yr1 = mod(year,400) - if(yr1 == 0) yr1 = 400 - day1 = date_to_day(yr1,month,day) - if(day1 == invalid_date) then - err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) - set_date_gregorian = .false. - return - endif - - Time_out%days = day1 + days_in_400_year_period*((year-1)/400) - Time_out%ticks = tick - err_msg = '' - set_date_gregorian = .true. - - end function set_date_gregorian -!:MKL - function set_date_gregorian2(year, month, day, hour, minute, second, tick, Time_out, err_msg) - logical :: set_date_gregorian2 - -! Computes time corresponding to date for gregorian calendar. - - integer, intent(in) :: year, month, day, hour, minute, second, tick - type(time_type), intent(out) :: Time_out - character(len=*), intent(out) :: err_msg - integer :: yr1, day1 - integer :: ncenturies, nlpyrs, l + l = 0 ; if( leap_year_gregorian_int(year) ) l = 1 - if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then - set_date_gregorian2 = .false. - return - endif + ! Check if date is invalid + if( month.ne.2 ) then + if ( day.gt.days_per_month(month) .or. day.lt.1 ) then + err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_gregorian = .false. + return + end if + else if (month.eq.2 ) then + if ( day.gt.days_per_month(month)+l .or. day.lt.1 ) then + err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) + set_date_gregorian = .false. + return + end if + end if Time_out%seconds = second + 60*(minute + 60*hour) @@ -2373,7 +2197,6 @@ function set_date_gregorian2(year, month, day, hour, minute, second, tick, Time_ if( ncenturies.eq.4) day1 = day1 + 1 end if - l = 0 ; if( leap_year_gregorian_int(year) ) l = 1 select case( month ) case(1) ; day1 = day1 case(2) ; day1 = day1 + 31 @@ -2391,18 +2214,18 @@ function set_date_gregorian2(year, month, day, hour, minute, second, tick, Time_ day1 = int((year-1)/400)*days_in_400_year_period + day1 + day - 1 - if(day1 == invalid_date) then + if(day1 == invalid_date) then err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second) - set_date_gregorian2 = .false. + set_date_gregorian = .false. return endif Time_out%days = day1 Time_out%ticks = tick err_msg = '' - set_date_gregorian2 = .true. + set_date_gregorian = .true. -end function set_date_gregorian2 + end function set_date_gregorian !------------------------------------------------------------------------