!############################################################################### ! ! go_date - module to manipulate date structures ! ! TYPES ! ! A structure is provided to store a date: ! ! ! declare date types: ! type(TDate) :: t0, t1, t, dt ! ! with fields: ! ! character(len=4) :: calender ! see 'CALENDERS' ! ! integer :: year, month, day, hour, min, sec, mili ! ! integer :: zone ! minutes; add this to obtain GMT ! ! ! CALENDERS ! ! A number of different calender types is supported: ! ! 'wall' : wall clock time, including time zone ! ! 'greg' : Gregorian calender, some years have a Februari 29 ! '366' : every year has a Februari 29 ! '365' : a year has never a Februari 29 ! '360' : every month has 30 days ! ! 'incr' : incremental time step: year=0, month=0, day >= 0 ! ! The 'incr' type is a special calender which has no year ! or month but might have any number of days. ! Note that day==1 has the interpretation of 24 hours for an 'incr', ! but means 'first' or 0 hours for one of the regular calenders. ! ! Use the calender '360' if only operations on years and months are required. ! ! ! CREATING DATE STRUCTURES ! ! To initialize a new date structure, a few routines are available. ! ! Use routine 'NewDate' to initialize some fields and to fill ! the rest with zero's. If no calender is specified, ! the default value 'greg' is used (see also DEFAULTS). ! ! t = NewDate( calender='greg', year=2000, month=1, ... ) ! ! Use routine 'IncrDate' to create a new increment; ! this is in fact a shorthand for a call to 'NewDate': ! ! t = IncrDate( year=2000, month=1 ) ! ! Fill the time from the system clock in a date structure: ! ! t = go_SystemDate() ! ! ! FIELD MANIPULATION ! ! Use 'Set' to fill some specific fields of a date structure. ! Special arrays: ! time4 = (/year,month,day,hour/) ! time5 = (/year,month,day,hour,min/) ! time6 = (/year,month,day,hour,min,sec/) ! Example: ! ! call Set( t [,year=2000] [,month=1] [,day=2] ... & ! [,time4=time4] [,time5=time5] [,time6=time6]) ! ! Use 'Get' to obtain some specific fields of a date structure. ! ! call Get( t [,year=year] [,month=month] ... & ! [,time4=time4] [,time5=time5] [,time6=time6] ) ! ! Check contents of a date structure: ! ! call Check( t ) ! ! Normalize hours to {0,..,23}, minutes to {0,..,59}, etc: ! ! call Normalize( t ) ! ! ! INQUIRY FUNCTIONS ! ! A few inquiry functions are provided. ! ! The logical function 'LeapYear' tells you if the year ! has a Februari 29 : ! ! l = LeapYear( t ) ! ! Two integer functions are provided to count the total number ! of days in a month or a year: ! ! i = Days_in_Month( t ) ! i = Days_in_Year( t ) ! ! An integer function is provided to return the day number, ! counting from 1 (Januari 1) to 360, 365, or 366 (last of December): ! ! i = DayNumber( t ) ! ! ! OPERATORS ! ! Operators '+' and '-' are redefined to perform operations ! between two date structures. ! Both should be of same calender type, or one should be ! an increment: ! ! t = t1 + t2 ! t = t1 - t2 ! ! Operators '*' and '/' are redefined for multiplication with ! or division by a real or an integer: ! ! t = t1 + dt * 2 ! t = t1 + dt * 3.1415 ! t = t1 + dt / 3.1415 ! ! ! LOGICAL OPERATORS ! ! Operators '==', '/=', '<', '<=', '>', '>=' are defined to ! compare two dates. ! ! ! SUMMATION ROUTINES ! ! The total number in a certain unit is returned by 'rTotal' ! (real value) or 'iTotal' (integer, error if not possible). ! Currently supported units are 'year', 'month', 'day', ! 'hour', 'min', 'sec', and 'mili'. If the total number is ! not wel defined for a certain date, for example the ! total number of years of today, an error message is produced. ! ! r = rTotal( t, 'year'|'month'|... ) ! i = iTotal( t, 'year'|'month'|... ) ! ! ! INTERPOLATION ! ! For t in [t1,t2], return real coefficients alfa1 and alf2 such that: ! t = alfa1 * t1 + alfa2 * t2 ! Usefull for linear interpolation: ! f(t) ~ alfa1 * f(t1) + alfa2 * f(t2) ! ! call InterpolFractions( t, t1, t2, alfa1, alfa2, status ) ! ! ! OUTPUT ! ! To obtain a pretty formatted print of the value of a date, ! the 'Pretty' routine is provided. Output differs based on ! the calender type. ! ! print *, 't = '//trim(Pretty(t)) ! ! Some compilers have problems with this kind of statements. ! Therefore, also a routine is provided: ! ! call PrintDate( 't = ', t ) ! ! ! DEFAULTS ! ! For setting some default values, the subroutine 'go_DateDefaults' ! is available. All arguments are optional: ! ! call go_DateDefaults( [calender='greg'] ) ! ! !############################################################################### ! #define IF_NOTOK_RETURN(action) if (status/=0) then; write (gol,'("in ",a)') rname; call goErr; action; return; end if ! ! print times up to minutes: #define PRINT_MINU ! !############################################################################### module GO_Date use GO_Print, only : gol, goErr, goPr implicit none ! --- in/out --------------------------- private public :: TDate, TIncrDate public :: goDateDefaults public :: NewDate, IncrDate, AnyDate, SystemDate public :: Set, Get public :: Check public :: Normalize public :: LeapYear public :: days_in_month public :: days_in_year public :: DayNumber public :: operator(+) public :: operator(-) public :: operator(*) public :: operator(/) public :: Pretty public :: IsAnyDate public :: operator(==) public :: operator(/=) public :: operator(>) public :: operator(<) public :: operator(>=) public :: operator(<=) public :: rTotal, iTotal public :: InterpolFractions public :: wrtgol ! --- const ----------------------------------- character(len=*), parameter :: mname = 'GO_Date' ! --- types ------------------------------------- ! Strucure with fields to store year, month, day, ! hour and minute. ! Operators for assignment (=), adding (+), ! and comparission (==,<,>,>= and <=) ! have been defined for operations between ! instances of this type. type TDate ! type of calender: 'greg', '365', '360' character(len=4) :: calender ! year, month etc: integer :: year, month, day, hour, min, sec, mili ! difference with Coordinated Universal Time (UTC) integer :: zone ! minutes ! error status integer :: status = 1 end type TDate type TIncrDate ! days, hours, etc: integer :: day, hour, min, sec, mili ! error status integer :: status = 1 end type TIncrDate ! --- var -------------------------------- ! default calender type character(len=4) :: default_calender = 'greg' ! --- interface --------------------------- interface Pretty module procedure date_Pretty module procedure incrdate_Pretty end interface interface Check module procedure date_Check module procedure incrdate_Check end interface ! * interface LeapYear module procedure date_LeapYear end interface interface days_in_month module procedure date_days_in_month end interface interface days_in_year module procedure date_days_in_year end interface interface DayNumber module procedure date_DayNumber end interface ! * interface Set module procedure date_Set module procedure incrdate_Set end interface interface Get module procedure date_Get module procedure incrdate_Get end interface ! * interface NewDate module procedure date_NewDate end interface interface AnyDate module procedure date_AnyDate end interface interface IncrDate module procedure incrdate_IncrDate end interface interface SystemDate module procedure date_SystemDate end interface ! * operators interface Normalize module procedure date_Normalize module procedure incrdate_Normalize end interface interface operator(+) module procedure t_plus_t module procedure t_plus_dt module procedure dt_plus_dt end interface interface operator(-) module procedure t_min_t module procedure t_min_dt module procedure dt_min_dt end interface interface operator(*) module procedure dt_times_r module procedure r_times_dt module procedure dt_times_i module procedure i_times_dt end interface interface operator(/) module procedure dt_div_r module procedure dt_div_i end interface ! * logical operators interface IsAnyDate module procedure date_IsAnyDate end interface interface operator(==) module procedure date_eq_date end interface interface operator(/=) module procedure date_ne_date end interface interface operator(>) module procedure date_gt_date end interface interface operator(<) module procedure date_lt_date end interface interface operator(>=) module procedure date_ge_date end interface interface operator(<=) module procedure date_le_date end interface ! * interface rTotal module procedure date_rTotal module procedure incr_rTotal end interface interface iTotal module procedure date_iTotal module procedure incrdate_iTotal end interface ! * interface InterpolFractions module procedure date_InterpolFractions end interface ! * interface wrtgol module procedure wrtgol_t module procedure wrtgol_dt module procedure wrtgol_t1_t2 module procedure wrtgol_t1_t2_t3 end interface contains ! **************************************************** ! *** ! *** set defaults ! *** ! **************************************************** subroutine goDateDefaults( calender ) ! --- in/out -------------------------------- character(len=*), intent(in), optional :: calender ! --- begin ---------------------------------- if ( present(calender) ) default_calender = calender end subroutine goDateDefaults ! **************************************************** ! *** ! *** check ! *** ! **************************************************** ! ! Check fields of a date: ! range etc ! subroutine date_Check( t, status ) use GO_Print, only : gol, goErr ! --- in/out ---------------------------------- type(TDate), intent(in) :: t integer, intent(out) :: status ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_Check' ! --- begin ----------------------------------- ! already error status ? then leave immediatelly: if ( t%status /= 0 ) then write (gol,'("found error status in date")'); call goErr write (gol,'(" year,month,day : ",3i6)') t%year, t%month, t%day; call goErr write (gol,'(" hour,minu,sec,mili : ",4i6)') t%hour, t%min, t%sec, t%mili; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! calender specific select case ( t%calender ) case ( 'any' ) ! always ok ... status = 0 return case ( 'wall' ) ! no special tests case ( 'greg', '366', '365', '360' ) ! check month if ( t%month<1 .or. t%month>12 ) then call wrtgol( 'strange month in ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! check day if ( t%day<1 .or. t%day>days_in_month(t) ) then call wrtgol( 'strange day in ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! zone should be zero: if ( t%zone /= 0 ) then call wrtgol( 'expecting zero zone in date ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if case default write (gol,'("unknown calender type: `",a,"`")') t%calender; call goErr write (gol,'(" year etc : ",6i5)') t%year, t%month, t%day, t%hour, t%min, t%sec; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end select ! check minutes if ( t%min<0 .or. t%min>59 ) then call wrtgol( 'found strange minutes in ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! check seconds if ( t%sec<0 .or. t%sec>59 ) then call wrtgol( 'found strange seconds in ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! check mili if ( t%mili<0 .or. t%mili>999 ) then call wrtgol( 'found strange mili seconds in ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! ok status = 0 end subroutine date_Check ! *** subroutine incrdate_Check( dt, status ) use GO_Print, only : gol, goErr ! --- in/out ---------------------------------- type(TIncrDate), intent(in) :: dt integer, intent(out) :: status ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/incrdate_Check' ! --- begin ----------------------------------- ! already error status ? then leave immediatelly: if ( dt%status /= 0 ) then write (gol,'("found error status in incrdate")'); call goErr write (gol,'(" day, hour,minu,sec,mili : ",5i6)') dt%day, dt%hour, dt%min, dt%sec, dt%mili; call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! every value is allowed for increments ... ! ok status = 0 end subroutine incrdate_Check ! **************************************************** ! *** ! *** computation ! *** ! **************************************************** ! Does this year have a 29 feb ? logical function calc_LeapYear( year ) ! --- in/out ------------------------------- integer, intent(in) :: year ! --- begin -------------------------------- calc_LeapYear = ( (mod(year,4)==0) .and. .not.(mod(year,100)==0) ) & .or. (mod(year,400)==0) end function calc_LeapYear ! *** ! days per month integer function calc_days_in_month( calender, year, month ) use GO_Print, only : gol, goErr ! --- in/out --------------------------- character(len=*), intent(in) :: calender integer, intent(in) :: year, month ! --- const ----------------------------- character(len=*), parameter :: rname = mname//'/calc_days_in_month' ! --- const ----------------------------- ! days in a month 1 2 3 4 5 6 7 8 9 10 11 12 integer, parameter :: days365(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) ! normal integer, parameter :: days366(12) = (/31,29,31,30,31,30,31,31,30,31,30,31/) ! leap year integer, parameter :: days360(12) = (/30,30,30,30,30,30,30,30,30,30,30,30/) ! fixed month ! --- begin ---------------- select case ( calender ) case ( 'wall', 'greg' ) if ( calc_LeapYear(year) ) then calc_days_in_month = days366(month) else calc_days_in_month = days365(month) end if case ( '366' ) calc_days_in_month = days366(month) case ( '365' ) calc_days_in_month = days365(month) case ( '360' ) calc_days_in_month = days360(month) case ( 'any' ) calc_days_in_month = 0 case default calc_days_in_month = -1 write (gol,'("unknown calender type: ",a)') calender; call goErr write (gol,'("in ",a)') rname; call goErr; calc_days_in_month=-1; return end select end function calc_days_in_month ! *** ! days per month integer function calc_days_in_year( calender, year ) use GO_Print, only : gol, goErr ! --- in/out ---------------- character(len=*), intent(in) :: calender integer, intent(in) :: year ! --- const ----------------------------- character(len=*), parameter :: rname = mname//'/calc_days_in_year' ! --- begin ---------------- select case ( calender ) case ( 'wall', 'greg' ) if ( calc_LeapYear(year) ) then calc_days_in_year = 366 else calc_days_in_year = 365 end if case ( '366' ) calc_days_in_year = 366 case ( '365' ) calc_days_in_year = 365 case ( '360' ) calc_days_in_year = 360 case ( 'any' ) calc_days_in_year = 0 case default write (gol,'("unknown calender type: ",a)') calender; call goErr write (gol,'("in ",a)') rname; call goErr; calc_days_in_year=-1; return end select end function calc_days_in_year ! *** ! Returns the number of the day spedified by the date iy/im/id. ! The existence of a february 29 is checked. ! ! ndays( 1995, 1, 1 ) = 1 ! ndays( 1995, 12, 31 ) = 365 ! ndays( 1996, 12, 31 ) = 366 29 feb every 4 year ... ! ndays( 1900, 12, 31 ) = 365 except every 100 year ... ! ndays( 2000, 12, 31 ) = 366 except every 400 year ... integer function calc_DayNumber( calender, year, month, day ) use GO_Print, only : gol, goErr ! --- in/out ---------------------------- character(len=*), intent(in) :: calender integer, intent(in) :: year, month, day ! --- const ----------------------------- character(len=*), parameter :: rname = mname//'/calc_DayNumber' ! --- local ----------------------------- integer :: imonth ! --- begin ---------------------------- select case ( calender ) case ( 'wall', 'greg', '366', '365', '360' ) calc_DayNumber = day do imonth = 1, month-1 calc_DayNumber = calc_DayNumber + calc_days_in_month(calender,year,imonth) end do case ( 'any' ) calc_DayNumber = 0 case default write (gol,'("unknown calender type: ",a)') calender; call goErr write (gol,'("in ",a)') rname; call goErr; calc_DayNumber=-1; return end select end function calc_DayNumber ! ********************************************** logical function date_LeapYear( t ) ! --- in/out ------------------------------- type(TDate), intent(in) :: t ! --- begin -------------------------------- ! calender specific select case ( t%calender ) case ( 'wall', 'greg' ) ! see above ... date_LeapYear = calc_LeapYear( t%year ) case default ! no leap years ... date_LeapYear = .false. end select end function date_LeapYear ! *** integer function date_days_in_month( t ) ! --- in/out ---------------- type(TDate), intent(in) :: t ! --- begin ---------------- date_days_in_month = calc_days_in_month( t%calender, t%year, t%month ) end function date_days_in_month ! *** integer function date_days_in_year( t ) ! --- in/out ---------------- type(TDate), intent(in) :: t ! --- begin ---------------- date_days_in_year = calc_days_in_year( t%calender, t%year ) end function date_days_in_year ! *** integer function date_DayNumber( t ) ! --- in/out ---------------- type(TDate), intent(in) :: t ! --- begin ---------------- date_DayNumber = calc_DayNumber( t%calender, t%year, t%month, t%day ) end function date_DayNumber ! **************************************************** ! *** ! *** Set/Get fields in a structure TDate ! *** ! **************************************************** ! ! Fill fields in a 'TDate' structure. ! subroutine date_Set( date, year, month, day, hour, min, sec, mili, & zone, calender, time4, time5, time6 ) ! --- in/out ------------------------------------ type(TDate), intent(inout) :: date integer, intent(in), optional :: year integer, intent(in), optional :: month integer, intent(in), optional :: day integer, intent(in), optional :: hour integer, intent(in), optional :: min integer, intent(in), optional :: sec integer, intent(in), optional :: mili integer, intent(in), optional :: zone character(len=*), intent(in), optional :: calender integer, intent(in), optional :: time4(4) integer, intent(in), optional :: time5(5) integer, intent(in), optional :: time6(6) ! --- local ---------------------------------- if ( present(calender) ) date%calender = calender if ( present(time4) ) then date%year = time4(1) date%month = time4(2) date%day = time4(3) date%hour = time4(4) end if if ( present(time5) ) then date%year = time5(1) date%month = time5(2) date%day = time5(3) date%hour = time5(4) date%min = time5(5) end if if ( present(time6) ) then date%year = time6(1) date%month = time6(2) date%day = time6(3) date%hour = time6(4) date%min = time6(5) date%sec = time6(6) end if if ( present(year ) ) date%year = year if ( present(month) ) date%month = month if ( present(day ) ) date%day = day if ( present(zone ) ) date%zone = zone if ( present(hour ) ) date%hour = hour if ( present(min ) ) date%min = min if ( present(sec ) ) date%sec = sec if ( present(mili ) ) date%mili = mili end subroutine date_Set ! * subroutine incrdate_Set( date, day, hour, min, sec, mili ) ! --- in/out ------------------------------------ type(TIncrDate), intent(inout) :: date integer, intent(in), optional :: day integer, intent(in), optional :: hour integer, intent(in), optional :: min integer, intent(in), optional :: sec integer, intent(in), optional :: mili ! --- local ---------------------------------- if ( present(day ) ) date%day = day if ( present(hour ) ) date%hour = hour if ( present(min ) ) date%min = min if ( present(sec ) ) date%sec = sec if ( present(mili ) ) date%mili = mili end subroutine incrdate_Set ! ! Obtain fields from a 'TDate' structure. ! subroutine date_Get( date, & year, month, day, hour, min, sec, mili, & zone, calender, time4, time5, time6 ) ! --- in/out ------------------------------------ type(TDate), intent(in) :: date integer, intent(out), optional :: year, month, day integer, intent(out), optional :: hour, min, sec, mili integer, intent(out), optional :: zone integer, intent(out), optional :: time4(4) integer, intent(out), optional :: time5(5) integer, intent(out), optional :: time6(6) character(len=*), intent(out), optional :: calender ! --- local ---------------------------------- if ( present(calender) ) calender = date%calender if ( present(year) ) year = date%year if ( present(month) ) month = date%month if ( present(day ) ) day = date%day if ( present(zone ) ) zone = date%zone if ( present(hour ) ) hour = date%hour if ( present(min ) ) min = date%min if ( present(sec ) ) sec = date%sec if ( present(mili ) ) mili = date%mili if ( present(time4) ) time4 = (/ date%year, date%month, date%day, date%hour /) if ( present(time5) ) time5 = (/ date%year, date%month, date%day, & date%hour, date%min /) if ( present(time6) ) time6 = (/ date%year, date%month, date%day, & date%hour, date%min , date%sec /) end subroutine date_Get ! * subroutine incrdate_Get( date, day, hour, min, sec, mili ) ! --- in/out ------------------------------------ type(TIncrDate), intent(in) :: date integer, intent(out), optional :: day integer, intent(out), optional :: hour, min, sec, mili ! --- local ---------------------------------- if ( present(day ) ) day = date%day if ( present(hour ) ) hour = date%hour if ( present(min ) ) min = date%min if ( present(sec ) ) sec = date%sec if ( present(mili ) ) mili = date%mili end subroutine incrdate_Get ! **************************************************** ! *** ! *** Return a date structure ! *** ! **************************************************** ! ! Set fields to zero or fill some of them. ! type(TDate) function date_NewDate( year, month, day, hour, min, sec, mili, & zone, calender, time4, time5, time6 ) ! --- in/out ------------------------------------ integer, intent(in), optional :: year, month, day integer, intent(in), optional :: hour, min, sec, mili integer, intent(in), optional :: zone character(len=*), intent(in), optional :: calender integer, intent(in), optional :: time4(4) integer, intent(in), optional :: time5(5) integer, intent(in), optional :: time6(6) ! --- local ---------------------------------- ! set default calender type: date_NewDate%calender = default_calender ! Fields are zero by default: date_NewDate%year = 0 date_NewDate%month = 0 date_NewDate%day = 0 date_NewDate%zone = 0 date_NewDate%hour = 0 date_NewDate%min = 0 date_NewDate%sec = 0 date_NewDate%mili = 0 ! Optionally, change some of them: if ( present(year ) ) call Set( date_NewDate, year=year ) if ( present(month ) ) call Set( date_NewDate, month=month ) if ( present(day ) ) call Set( date_NewDate, day=day ) if ( present(hour ) ) call Set( date_NewDate, hour=hour ) if ( present(min ) ) call Set( date_NewDate, min=min ) if ( present(sec ) ) call Set( date_NewDate, sec=sec ) if ( present(mili ) ) call Set( date_NewDate, mili=mili ) if ( present(zone ) ) call Set( date_NewDate, zone=zone ) if ( present(calender) ) call Set( date_NewDate, calender=calender ) if ( present(time4 ) ) call Set( date_NewDate, time4=time4 ) if ( present(time5 ) ) call Set( date_NewDate, time5=time5 ) if ( present(time6 ) ) call Set( date_NewDate, time6=time6 ) ! normalize too small/too large values: if ( date_NewDate%year /= 0000 ) call Normalize( date_NewDate ) ! data filled, thus probably no error ... date_NewDate%status = 0 end function date_NewDate ! *** type(TIncrDate) function incrdate_IncrDate( day, hour, min, sec, mili ) ! --- in/out ------------------------------------ integer, intent(in), optional :: day integer, intent(in), optional :: hour, min, sec, mili ! --- local ---------------------------------- ! Fields are zero by default: incrdate_IncrDate%day = 0 incrdate_IncrDate%hour = 0 incrdate_IncrDate%min = 0 incrdate_IncrDate%sec = 0 incrdate_IncrDate%mili = 0 ! Optionally, change some of them: if ( present(day ) ) call Set( incrdate_IncrDate, day=day ) if ( present(hour ) ) call Set( incrdate_IncrDate, hour=hour ) if ( present(min ) ) call Set( incrdate_IncrDate, min=min ) if ( present(sec ) ) call Set( incrdate_IncrDate, sec=sec ) if ( present(mili ) ) call Set( incrdate_IncrDate, mili=mili ) ! normalize too small/too large values: call Normalize( incrdate_IncrDate ) ! data filled, thus probably no error ... incrdate_IncrDate%status = 0 end function incrdate_IncrDate ! *** ! ! Set fields to zero, special calender ! type(TDate) function date_AnyDate() ! --- local ---------------------------------- ! Set some fields, other are automatically zero: date_AnyDate = NewDate( calender='any' ) end function date_AnyDate ! *** ! Fill with system time type(TDate) function date_SystemDate() ! --- in/out ------------------------------ ! none ... ! --- local ------------------------------ integer :: values(8) ! --- begin ------------------------------ ! ! Optional character output of Date_and_Time: ! ! date '20020812' ! time '211757.314' ! zone '+0200' ! ! obtain system date and time: call Date_and_Time( values=values ) ! fill fields in structure: call Set( date_SystemDate, calender='wall', & year=values(1), month=values(2), day=values(3), & zone=values(4), hour=values(5), & min=values(6), sec=values(7), mili=values(8) ) ! Date probably ok. date_SystemDate%status = 0 end function date_SystemDate ! ************************************************ ! *** ! *** operators ! *** ! ************************************************ subroutine date_Normalize( t ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(inout) :: t ! --- const ----------------------------- character(len=*), parameter :: rname = mname//'/date_Normalize' ! --- begin --------------------------------- ! mili seconds do if ( t%mili >= 0 ) exit t%sec = t%sec - 1 t%mili = t%mili + 1000 end do do if ( t%mili <= 999 ) exit t%mili = t%mili - 1000 t%sec = t%sec + 1 end do ! seconds do if ( t%sec >= 0 ) exit t%min = t%min - 1 t%sec = t%sec + 60 end do do if ( t%sec <= 59 ) exit t%sec = t%sec - 60 t%min = t%min + 1 end do ! minutes do if ( t%min >= 0 ) exit t%hour = t%hour - 1 t%min = t%min + 60 end do do if ( t%min <= 59 ) exit t%min = t%min - 60 t%hour = t%hour + 1 end do ! hours do if ( t%hour >= 0 ) exit t%day = t%day - 1 t%hour = t%hour + 24 end do do if ( t%hour <= 23 ) exit t%hour = t%hour - 24 t%day = t%day + 1 end do ! days, months, year select case ( t%calender ) case ( 'wall', 'greg', '366', '365', '360' ) do if ( t%day >= 1 ) exit t%month = t%month - 1 do if ( t%month >= 1 ) exit t%year = t%year - 1 t%month = t%month + 12 end do t%day = t%day + days_in_month(t) end do do if ( t%day <= days_in_month(t) ) exit t%day = t%day - days_in_month(t) t%month = t%month + 1 do if ( t%month <= 12 ) exit t%month = t%month - 12 t%year = t%year + 1 end do end do case default write (gol,'("unsupported calender type: ",a)') t%calender; call goErr write (gol,'("in ",a)') rname; call goErr; t%status=1; return end select end subroutine date_Normalize subroutine incrdate_Normalize( dt ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TIncrDate), intent(inout) :: dt ! --- const ----------------------------- character(len=*), parameter :: rname = mname//'/incrdate_Normalize' ! --- begin --------------------------------- ! mili seconds do if ( dt%mili >= 0 ) exit dt%sec = dt%sec - 1 dt%mili = dt%mili + 1000 end do do if ( dt%mili <= 999 ) exit dt%mili = dt%mili - 1000 dt%sec = dt%sec + 1 end do ! seconds do if ( dt%sec >= 0 ) exit dt%min = dt%min - 1 dt%sec = dt%sec + 60 end do do if ( dt%sec <= 59 ) exit dt%sec = dt%sec - 60 dt%min = dt%min + 1 end do ! minutes do if ( dt%min >= 0 ) exit dt%hour = dt%hour - 1 dt%min = dt%min + 60 end do do if ( dt%min <= 59 ) exit dt%min = dt%min - 60 dt%hour = dt%hour + 1 end do ! hours do if ( dt%hour >= 0 ) exit dt%day = dt%day - 1 dt%hour = dt%hour + 24 end do do if ( dt%hour <= 23 ) exit dt%hour = dt%hour - 24 dt%day = dt%day + 1 end do end subroutine incrdate_Normalize ! *** date = t1 + t2 ************************ ! ! t1 + t2 -> t1+t2 ! ! greg incr greg ! 366 incr 366 ! 365 incr 365 ! ! 360 360 360 ! 360 incr 360 ! ! incr greg greg ! incr 366 366 ! incr 365 365 ! incr 360 360 ! incr incr incr ! type(TDate) function t_plus_t( t1, t2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/t_plus_t' ! --- local -------------------------------- integer :: status ! --- begin --------------------------------- ! check arguments call Check( t1, status ) IF_NOTOK_RETURN(t_plus_t%status=1) call Check( t2, status ) IF_NOTOK_RETURN(t_plus_t%status=1) ! any date ? return any date .. if ( (t1%calender == 'any') .or. (t2%calender == 'any') ) then t_plus_t = AnyDate() return end if ! calenders should be the same: if ( t1%calender /= t2%calender ) then write (gol,'("calenders should be the same : ")'); call goPr write (gol,'(" t1 : ",a)') trim(t1%calender); call goPr write (gol,'(" t2 : ",a)') trim(t2%calender); call goPr write (gol,'("in ",a)') rname; call goErr; t_plus_t%status=1; return end if ! add all fields; t_plus_t = NewDate( calender=t1%calender, & year = t1%year + t2%year , & month = t1%month + t2%month , & day = t1%day + t2%day , & hour = t1%hour + t2%hour , & zone = t1%zone + t2%zone , & min = t1%min + t2%min , & sec = t1%sec + t2%sec , & mili = t1%mili + t2%mili ) end function t_plus_t ! * type(TDate) function t_plus_dt( t, dt ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t type(TIncrDate), intent(in) :: dt ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/t_plus_dt' ! --- local -------------------------------- integer :: status ! --- begin --------------------------------- ! check arguments call Check( t, status ) IF_NOTOK_RETURN(t_plus_dt%status=1) call Check( dt, status ) IF_NOTOK_RETURN(t_plus_dt%status=1) ! any date ? return any date .. if ( t%calender == 'any' ) then t_plus_dt = AnyDate() return end if ! add fields; normalization is applied in routine: t_plus_dt = NewDate( calender = t%calender, & year = t%year , & month = t%month , & day = t%day + dt%day , & hour = t%hour + dt%hour , & zone = t%zone , & min = t%min + dt%min , & sec = t%sec + dt%sec , & mili = t%mili + dt%mili ) end function t_plus_dt ! * type(TIncrDate) function dt_plus_dt( dt1, dt2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt1 type(TIncrDate), intent(in) :: dt2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/dt_plus_dt' ! --- local -------------------------------- integer :: status ! --- begin --------------------------------- ! check arguments call Check( dt1, status ) IF_NOTOK_RETURN(dt_plus_dt%status=1) call Check( dt2, status ) IF_NOTOK_RETURN(dt_plus_dt%status=1) ! add fields: dt_plus_dt = IncrDate( day = dt1%day + dt2%day , & hour = dt1%hour + dt2%hour , & min = dt1%min + dt2%min , & sec = dt1%sec + dt2%sec , & mili = dt1%mili + dt2%mili ) end function dt_plus_dt ! *** date = t1 - t2 ! ! t1 -> t2 -> t1-t2 action ! ! greg greg incr difference ! greg incr greg minus ! ! 366 366 incr difference ! 366 incr 366 minus ! ! 365 365 incr difference ! 365 incr 365 minus ! ! 360 360 360 difference ! 360 incr 360 minus ! ! incr incr incr difference ! type(TIncrDate) function t_min_t( t1, t2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/t_min_t' ! --- local --------------------------------- integer :: status character(len=5) :: action integer :: ndays type(TDate) :: t ! --- begin --------------------------------- ! check arguments call Check( t1, status ) IF_NOTOK_RETURN(t_min_t%status=1) call Check( t2, status ) IF_NOTOK_RETURN(t_min_t%status=1) ! any dates ? something wrong ... if ( (t1%calender == 'any') .or. (t2%calender == 'any') ) then write (gol,'("do not know how to compute difference between `any` dates ...")') write (gol,'("in ",a)') rname; call goErr; t_min_t%status=1; return end if ! calenders should be the same: if ( t1%calender /= t2%calender ) then write (gol,'("calenders should be the same : ")'); call goPr write (gol,'(" t1 : ",a)') trim(t1%calender); call goPr write (gol,'(" t2 : ",a)') trim(t2%calender); call goPr write (gol,'("in ",a)') rname; call goErr; t_min_t%status=1; return end if ! difference between two dates; result is an increment ! difference should be positive: if ( t1 < t2 ) then write (gol,'("expect t1 to exceed t2 :")'); call goErr call wrtgol( ' t1 : ', t1 ); call goErr call wrtgol( ' t2 : ', t2 ); call goErr write (gol,'("in ",a)') rname; call goErr; t_min_t%status=1; return end if ! determine number of days between t1 and t2: t = t1 ndays = daynumber(t) - 1 do if ( t%year==t2%year ) exit t%year = t%year - 1 ndays = ndays + days_in_year(t) end do ndays = ndays - (daynumber(t2)-1) ! store result: t_min_t = IncrDate( day = ndays, & hour = t1%hour - t2%hour, & min = t1%min - t2%min , & sec = t1%sec - t2%sec , & mili = t1%mili - t2%mili ) end function t_min_t ! * type(TDate) function t_min_dt( t, dt ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t type(TIncrDate), intent(in) :: dt ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/t_min_dt' ! --- local --------------------------------- integer :: status ! --- begin --------------------------------- ! check arguments call Check( t, status ) IF_NOTOK_RETURN(t_min_dt%status=1) call Check( dt, status ) IF_NOTOK_RETURN(t_min_dt%status=1) ! any date ? return any date .. if ( t%calender == 'any' ) then t_min_dt = AnyDate() return end if ! result is of same type as t; ! normalization is done in NewDate t_min_dt = NewDate( calender = t%calender , & year = t%year , & month = t%month , & day = t%day -dt%day , & hour = t%hour -dt%hour , & zone = t%zone , & min = t%min -dt%min , & sec = t%sec -dt%sec , & mili = t%mili -dt%mili ) end function t_min_dt ! * type(TIncrDate) function dt_min_dt( dt1, dt2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt1 type(TIncrDate), intent(in) :: dt2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/dt_min_dt' ! --- local --------------------------------- integer :: status ! --- begin --------------------------------- ! check arguments call Check( dt1, status ) IF_NOTOK_RETURN(dt_min_dt%status=1) call Check( dt2, status ) IF_NOTOK_RETURN(dt_min_dt%status=1) ! fill result: dt_min_dt = IncrDate( day = dt1%day - dt2%day , & hour = dt1%hour - dt2%hour, & min = dt1%min - dt2%min , & sec = dt1%sec - dt2%sec , & mili = dt1%mili - dt2%mili ) end function dt_min_dt ! *** date = t * r ************************************************ ! multiply time with a real factor; ! use round for fractions type(TIncrDate) function dt_times_r( dt, r ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt real, intent(in) :: r ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/dt_times_r' ! --- local ----------------------------------- integer :: status ! --- begin --------------------------------- call Check( dt, status ) IF_NOTOK_RETURN(dt_times_r%status=1) ! multiply each of the parts with r, round dt_times_r = IncrDate( day = nint( dt%day * r ), & hour = nint( dt%hour * r ), & min = nint( dt%min * r ), & sec = nint( dt%sec * r ), & mili = nint( dt%mili * r ) ) end function dt_times_r ! * type(TIncrDate) function r_times_dt( r, dt ) ! --- in/out -------------------------------- real, intent(in) :: r type(TIncrDate), intent(in) :: dt ! --- begin --------------------------------- r_times_dt = dt * r end function r_times_dt ! * type(TIncrDate) function dt_times_i( dt, i ) ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt integer, intent(in) :: i ! --- begin --------------------------------- dt_times_i = dt * (i*1.0) end function dt_times_i ! * type(TIncrDate) function i_times_dt( i, dt ) ! --- in/out -------------------------------- integer, intent(in) :: i type(TIncrDate), intent(in) :: dt ! --- begin --------------------------------- i_times_dt = dt * i end function i_times_dt ! *** dt = dt / r ************************************************ type(TIncrDate) function dt_div_r( dt, r ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt real, intent(in) :: r ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/dt_div_r' ! --- local --------------------------------- integer :: status real :: rat integer :: intg real :: frac ! --- begin --------------------------------- call Check( dt, status ) IF_NOTOK_RETURN(dt_div_r%status=1) ! days: rat = dt%day / r intg = floor( rat ) frac = rat - intg dt_div_r = IncrDate( day=intg ) ! hours: rat = dt%hour / r + frac*24 intg = floor( rat ) frac = rat - intg call Set( dt_div_r, hour=intg ) ! mins: rat = dt%min / r + frac*60 intg = floor( rat ) frac = rat - intg call Set( dt_div_r, min=intg ) ! seconds: rat = dt%sec / r + frac*60 intg = floor( rat ) frac = rat - intg call Set( dt_div_r, sec=intg ) ! miliseconds: rat = dt%mili / r + frac*1000 intg = floor( rat ) frac = rat - intg call Set( dt_div_r, mili=intg ) end function dt_div_r ! * type(TIncrDate) function dt_div_i( dt, i ) ! --- in/out -------------------------------- type(TIncrDate), intent(in) :: dt integer, intent(in) :: i ! --- begin --------------------------------- dt_div_i = dt / (i*1.0) end function dt_div_i ! ************************************************ ! *** ! *** logical operators ! *** ! ************************************************ logical function date_IsAnyDate( t ) ! --- in/out ------------------------------- type(TDate), intent(in) :: t ! --- begin -------------------------------- date_IsAnyDate = t%calender == 'any' end function date_IsAnyDate ! *** date1 == date2 logical function date_eq_date( t1, t2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_eq_date' ! --- local ----------------------------------- integer :: status ! --- begin --------------------------------- call Check( t1, status ) IF_NOTOK_RETURN(date_eq_date=.false.) call Check( t2, status ) IF_NOTOK_RETURN(date_eq_date=.false.) ! any date ? always equal if ( (t1%calender == 'any') .or. (t2%calender == 'any') ) then date_eq_date = .true. return end if ! compare values date_eq_date = & ( t1%year == t2%year ) .and. & ( t1%month == t2%month ) .and. & ( t1%day == t2%day ) .and. & ( t1%zone == t2%zone ) .and. & ( t1%hour == t2%hour ) .and. & ( t1%min == t2%min ) .and. & ( t1%sec == t2%sec ) .and. & ( t1%mili == t2%mili ) end function date_eq_date ! *** date1 /= date2 logical function date_ne_date( t1, t2 ) ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_ne_date' ! --- begin --------------------------------- date_ne_date = .not. ( t1 == t2 ) end function date_ne_date ! *** date1 > date2 logical function date_gt_date( t1, t2 ) use go_print, only : gol, goErr ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_gt_date' ! --- local ----------------------------------- integer :: status ! --- begin --------------------------------- call Check( t1, status ) IF_NOTOK_RETURN(date_gt_date=.false.) call Check( t2, status ) IF_NOTOK_RETURN(date_gt_date=.false.) ! any date ? always true if ( (t1%calender == 'any') .or. (t2%calender == 'any') ) then date_gt_date = .true. return end if if ( t1%year > t2%year ) then date_gt_date = .true. return else if ( t1%year < t2%year ) then date_gt_date = .false. return end if if ( t1%month > t2%month ) then date_gt_date = .true. return else if ( t1%month < t2%month ) then date_gt_date = .false. return end if if ( t1%day > t2%day ) then date_gt_date = .true. return else if ( t1%day < t2%day ) then date_gt_date = .false. return end if if ( t1%hour > t2%hour ) then date_gt_date = .true. return else if ( t1%hour < t2%hour ) then date_gt_date = .false. return end if if ( t1%min > t2%min ) then date_gt_date = .true. return else if ( t1%min < t2%min ) then date_gt_date = .false. return end if if ( t1%sec > t2%sec ) then date_gt_date = .true. return else if ( t1%sec < t2%sec ) then date_gt_date = .false. return end if if ( t1%mili > t2%mili ) then date_gt_date = .true. return else if ( t1%mili < t2%mili ) then date_gt_date = .false. return end if ! all fields are equal ... date_gt_date = .false. end function date_gt_date ! *** date1 < date2 logical function date_lt_date( t1, t2 ) ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- begin --------------------------------- date_lt_date = (.not.( ( t1 == t2 ) .or. ( t1 > t2 ) )) .or. IsAnyDate(t1) .or. IsAnyDate(t2) end function date_lt_date ! *** date1 >= date2 ************************ logical function date_ge_date( t1, t2 ) ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- begin --------------------------------- date_ge_date = ( t1 == t2 ) .or. ( t1 > t2 ) .or. IsAnyDate(t1) .or. IsAnyDate(t2) end function date_ge_date ! *** date1 <= date2 ************************ logical function date_le_date( t1, t2 ) ! --- in/out -------------------------------- type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 ! --- begin --------------------------------- date_le_date = (.not. ( t1 > t2 )) .or. IsAnyDate(t1) .or. IsAnyDate(t2) end function date_le_date ! *********************************************** ! *** ! *** totals ! *** ! *********************************************** real function date_rTotal( t, unit ) use go_print, only : gol, goErr ! --- in/out ---------------------------- type(TDate), intent(in) :: t character(len=*), intent(in) :: unit ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_rTotal' ! --- local ----------------------------------- integer :: status real :: nday integer :: iyear ! --- begin ----------------------------- call Check( t, status ) IF_NOTOK_RETURN(date_rTotal=-1.0) ! not all arguments are possible ... select case ( t%calender ) case ( 'wall', 'greg', '366', '365' ) select case ( unit ) case ( 'year' ) if ( any( (/t%month,t%day,t%hour,t%min,t%sec,t%mili/) /= 0 ) ) then write (gol,'("do not know how to count total:")'); call goErr write (gol,'(" unit : ",a)') unit; call goErr call wrtgol( ' t : ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; date_rTotal=-1; return end if case ( 'month' ) if ( any( (/t%day,t%hour,t%min,t%sec,t%mili/) /= 0 ) ) then write (gol,'("do not know how to count total:")'); call goErr write (gol,'(" unit : ",a)') unit; call goErr call wrtgol( ' t : ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; date_rTotal=-1; return end if end select case ( 'incr' ) select case ( unit ) case ( 'year', 'month' ) write (gol,'("do not know how to count total in incremental date:")') unit; call goErr write (gol,'(" unit : ",a)') unit; call goErr call wrtgol( ' t : ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; date_rTotal=-1; return end select end select ! precount total number of days for some of the units: select case ( unit ) case ( 'day', 'hour', 'min', 'sec', 'mili' ) nday = 0.0 do iyear = 1, t%year-1 nday = nday + calc_days_in_year(t%calender,iyear) end do nday = nday + DayNumber( t ) - 1 end select ! count time units: select case ( unit ) case ( 'year' ) ! set 'nday' to a reference length of the year; ! if this length is not constant during the years, the ! values of t%month etc have been checked to be zero: nday = days_in_year(t) * 1.0 ! count fractional years: date_rTotal = t%year + & t%month / 12.0 + & t%day / nday + & t%hour / nday / 24.0 + & t%min / nday / 24.0 / 60.0 + & t%sec / nday / 24.0 / 60.0 / 60.0 + & t%mili / nday / 24.0 / 60.0 / 60.0 / 1000.0 case ( 'month' ) ! set 'nday' to a reference length of the month; ! if this length is not constant during the years, the ! values of t%day etc been checked to be zero: nday = days_in_month(t) * 1.0 ! count fractional months: date_rTotal = t%year * 12.0 + & t%month + & t%day / nday + & t%hour / nday / 24.0 + & t%min / nday / 24.0 / 60.0 + & t%sec / nday / 24.0 / 60.0 / 60.0 + & t%mili / nday / 24.0 / 60.0 / 60.0 / 1000.0 case ( 'day' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional months: date_rTotal = nday + & t%hour / 24.0 + & t%min / 24.0 / 60.0 + & t%sec / 24.0 / 60.0 / 60.0 + & t%mili / 24.0 / 60.0 / 60.0 / 1000.0 case ( 'hour' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional hours: date_rTotal = nday * 24.0 + & t%hour + & t%min / 60.0 + & t%sec / 60.0 / 60.0 + & t%mili / 60.0 / 60.0 / 1000.0 case ( 'min' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional minutes: date_rTotal = nday * 24.0 * 60.0 + & t%hour * 60.0 + & t%min + & t%sec / 60.0 + & t%mili / 60.0 / 1000.0 case ( 'sec' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional seconds: date_rTotal = nday * 24.0 * 60.0 * 60.0 + & t%hour * 60.0 * 60.0 + & t%min * 60.0 + & t%sec + & t%mili / 1000.0 case ( 'mili' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional mili seconds: date_rTotal = nday * 24.0 * 60.0 * 6.00 * 1000.0 + & t%hour * 60.0 * 60.0 * 1000.0 + & t%min * 60.0 * 1000.0 + & t%sec * 1000.0 + & t%mili case default write (gol,'("do not know how to count time in unit : ",a)') trim(unit); call goErr write (gol,'("in ",a)') rname; call goErr; date_rTotal=-1.0; return end select end function date_rTotal ! *** real function incr_rTotal( dt, unit ) use go_print, only : gol, goErr ! --- in/out ---------------------------- type(TIncrDate), intent(in) :: dt character(len=*), intent(in) :: unit ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/incr_rTotal' ! --- local ----------------------------------- integer :: status ! --- begin ----------------------------- call Check( dt, status ) IF_NOTOK_RETURN(incr_rTotal=-1.0) ! count time units: select case ( unit ) case ( 'day' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional months: incr_rTotal = dt%day + & dt%hour / 24.0 + & dt%min / 24.0 / 60.0 + & dt%sec / 24.0 / 60.0 / 60.0 + & dt%mili / 24.0 / 60.0 / 60.0 / 1000.0 case ( 'hour' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional hours: incr_rTotal = dt%day * 24.0 + & dt%hour + & dt%min / 60.0 + & dt%sec / 60.0 / 60.0 + & dt%mili / 60.0 / 60.0 / 1000.0 case ( 'min' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional minutes: incr_rTotal = dt%day * 24.0 * 60.0 + & dt%hour * 60.0 + & dt%min + & dt%sec / 60.0 + & dt%mili / 60.0 / 1000.0 case ( 'sec' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional seconds: incr_rTotal = dt%day * 24.0 * 60.0 * 60.0 + & dt%hour * 60.0 * 60.0 + & dt%min * 60.0 + & dt%sec + & dt%mili / 1000.0 case ( 'mili' ) ! 'nday' has been set to the total number of days from 0 to t; ! count fractional mili seconds: incr_rTotal = dt%day * 24.0 * 60.0 * 6.00 * 1000.0 + & dt%hour * 60.0 * 60.0 * 1000.0 + & dt%min * 60.0 * 1000.0 + & dt%sec * 1000.0 + & dt%mili case default write (gol,'("do not know how to count time in unit : ",a)') trim(unit); call goErr write (gol,'("in ",a)') rname; call goErr; incr_rTotal=-1.0; return end select end function incr_rTotal ! *** integer function date_iTotal( t, unit ) use go_print, only : gol, goErr ! --- in/out ---------------------------- type(TDate), intent(in) :: t character(len=*), intent(in) :: unit ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/date_iTotal' ! --- local ----------------------------- integer :: status real :: rtot integer :: itot ! --- begin ----------------------------- call Check( t, status ) IF_NOTOK_RETURN(date_iTotal=-1) ! determine total some as a real value: rtot = rTotal( t, unit ) ! round to integer value: itot = nint(rtot) ! result should be pure integer .... if ( itot*1.0 == rtot ) then date_iTotal = itot else write (gol,'("date does not contain integer total:")'); call goErr write (gol,'(" unit : ",a)') trim(unit); call goErr call wrtgol( ' t : ', t ); call goErr write (gol,'("in ",a)') rname; call goErr; date_iTotal=-1; return end if end function date_iTotal ! *** integer function incrdate_iTotal( dt, unit ) use go_print, only : gol, goErr ! --- in/out ---------------------------- type(TIncrDate), intent(in) :: dt character(len=*), intent(in) :: unit ! --- const ----------------------------------- character(len=*), parameter :: rname = mname//'/incrdate_iTotal' ! --- local ----------------------------- integer :: status real :: rtot integer :: itot ! --- begin ----------------------------- call Check( dt, status ) IF_NOTOK_RETURN(incrdate_iTotal=-1) ! determine total some as a real value: rtot = rTotal( dt, unit ) ! round to integer value: itot = nint(rtot) ! result should be pure integer .... if ( itot*1.0 == rtot ) then incrdate_iTotal = itot else write (gol,'("date does not contain integer total:")'); call goErr write (gol,'(" unit : ",a)') trim(unit); call goErr call wrtgol( ' dt : ', dt ); call goErr write (gol,'("in ",a)') rname; call goErr; incrdate_iTotal=-1; return end if end function incrdate_iTotal ! *********************************************** ! *** ! *** interpolation ! *** ! *********************************************** ! ! Return coeff such that ! t = alfa1 * t1 + alfa2 * t2 ! subroutine date_InterpolFractions( t, t1, t2, alfa1, alfa2, status ) use go_print, only : gol, goErr ! --- in/out ----------------------------- type(TDate), intent(in) :: t type(TDate), intent(in) :: t1 type(TDate), intent(in) :: t2 real, intent(out) :: alfa1 real, intent(out) :: alfa2 integer, intent(out) :: status ! --- const ---------------------------------- character(len=*), parameter :: rname = mname//'/date_InterpolFractions' ! --- local ------------------------------ real :: ds, ds1 ! --- begin ------------------------------ ! check ... if ( t1 > t2 ) then write (gol,'("required interval [t1,t2] :")'); call goErr call wrtgol( ' t1 = ', t1 ); call goErr call wrtgol( ' t2 = ', t2 ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! check ... if ( (t < t1) .or. (t > t2) ) then write (gol,'("t not in [t1,t2] :")'); call goErr call wrtgol( ' t = ', t ); call goErr call wrtgol( ' t1 = ', t1 ); call goErr call wrtgol( ' t2 = ', t2 ); call goErr write (gol,'("in ",a)') rname; call goErr; status=1; return end if ! compute differences in seconds: ds = rTotal( t2 - t1, 'sec' ) ds1 = rTotal( t - t1, 'sec' ) ! return fractions if ( abs(ds) < tiny(ds) ) then alfa2 = 0.5 else alfa2 = ds1 / ds end if alfa1 = 1.0 - alfa2 end subroutine date_InterpolFractions ! *********************************************** ! *** ! *** print ! *** ! *********************************************** #ifdef PRINT_MINU #define PRINT_LEN 29 #else #define PRINT_LEN 36 #endif character(len=PRINT_LEN) function date_Pretty( t ) ! --- in/out ------------------------- type(TDate), intent(in) :: t ! --- const -------------------------- character(len=3), parameter :: month_name(12) = & (/ 'jan','feb','mar','apr','may','jun', & 'jul','aug','sep','oct','nov','dec' /) ! --- local -------------------------- integer :: zone_abs, zone_hour, zone_min character(len=1) :: zone_sign character(len=PRINT_LEN) :: s ! --- begin -------------------------- select case ( t%calender ) case ( 'wall' ) if ( t%zone < 0 ) then zone_sign = '-' else zone_sign = '+' end if zone_abs = abs(t%zone) zone_hour = floor(zone_abs/60.0) zone_min = zone_abs - zone_hour*60 write (s,'(i2,":",i2.2,":",i2.2,":",i3.3, & & " ",i2.2," ",a3," ",i4.4, & & " (GMT",a1,i2.2,":",i2.2,")")') & t%hour, t%min, t%sec, t%mili, & t%day, month_name(t%month), t%year, & zone_sign, zone_hour, zone_min case ( 'greg', 'PRINT_LEN6', 'PRINT_LEN5', 'PRINT_LEN0', 'any' ) #ifdef PRINT_MINU write (s,'(i4.4,"/",i2.2,"/",i2.2," ",i2,":",i2.2)') & t%year, t%month, t%day, t%hour, t%min #else write (s,'(i4.4,"/",i2.2,"/",i2.2," ",i2,":",i2.2,":",i2.2,":",i3.3)') & t%year, t%month, t%day, t%hour, t%min, t%sec, t%mili #endif case default s = 'no-calender' end select date_Pretty = s end function date_Pretty ! * character(len=PRINT_LEN) function incrdate_Pretty( dt ) ! --- in/out ------------------------- type(TIncrDate), intent(in) :: dt ! --- local -------------------------- integer :: zone_abs, zone_hour, zone_min character(len=1) :: zone_sign character(len=PRINT_LEN) :: s ! --- begin -------------------------- #ifdef PRINT_MINU write (s,'(i5," days ",i2,":",i2.2,":",i2.2,":",i3.3)') & dt%day, dt%hour, dt%min, dt%sec, dt%mili #else write (s,'(i5," days ",i2,":",i2.2)') & dt%day, dt%hour, dt%min #endif incrdate_Pretty = s end function incrdate_Pretty ! * subroutine wrtgol_t( msg, t ) use go_print, only : gol ! --- in/out ----------------------------------- character(len=*), intent(in) :: msg type(TDate), intent(in) :: t ! --- local --------------------------------- character(len=PRINT_LEN) :: s ! --- begin ----------------------------------- s = date_Pretty( t ) write (gol,'(a,a)') msg, trim(s) end subroutine wrtgol_t ! * subroutine wrtgol_dt( msg, dt ) use go_print, only : gol ! --- in/out ----------------------------------- character(len=*), intent(in) :: msg type(TIncrDate), intent(in) :: dt ! --- local --------------------------------- character(len=PRINT_LEN) :: s ! --- begin ----------------------------------- s = incrdate_Pretty( dt ) write (gol,'(a,a)') msg, trim(s) end subroutine wrtgol_dt ! * subroutine wrtgol_t1_t2( msg, t, msg2, t2 ) use go_print, only : gol ! --- in/out ----------------------------------- character(len=*), intent(in) :: msg type(TDate), intent(in) :: t character(len=*), intent(in) :: msg2 type(TDate), intent(in) :: t2 ! --- local --------------------------------- character(len=PRINT_LEN) :: s character(len=PRINT_LEN) :: s2 ! --- begin ----------------------------------- s = date_Pretty( t ) s2 = date_Pretty( t2 ) write (gol,'(a,a,a,a)') msg, trim(s), msg2, trim(s2) end subroutine wrtgol_t1_t2 ! * subroutine wrtgol_t1_t2_t3( msg, t, msg2, t2, msg3, t3 ) use go_print, only : gol ! --- in/out ----------------------------------- character(len=*), intent(in) :: msg type(TDate), intent(in) :: t character(len=*), intent(in) :: msg2 type(TDate), intent(in) :: t2 character(len=*), intent(in) :: msg3 type(TDate), intent(in) :: t3 ! --- local --------------------------------- character(len=PRINT_LEN) :: s character(len=PRINT_LEN) :: s2 character(len=PRINT_LEN) :: s3 ! --- begin ----------------------------------- s = date_Pretty( t ) s2 = date_Pretty( t2 ) s3 = date_Pretty( t3 ) write (gol,'(a,a,a,a,a,a)') msg, trim(s), msg2, trim(s2), msg3, trim(s3) end subroutine wrtgol_t1_t2_t3 end module GO_Date