Home

Context Navigation

source: palm/trunk/SOURCE/palm_date_time_mod.f90 @ 4816

Last change on this file since 4816 was 4797, checked in by raasch, 4 years ago
files re-formatted to follow the PALM coding standard
Property svn:keywords set to `Id`
File size: 31.2 KB

Rev	Line
[4227]	1	!> @file palm_date_time_mod.f90
[4680]	2	!--------------------------------------------------------------------------------------------------!
[4227]	3	! This file is part of the PALM model system.
	4	!
[4680]	5	! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
	6	! Public License as published by the Free Software Foundation, either version 3 of the License, or
	7	! (at your option) any later version.
[4227]	8	!
[4680]	9	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
	10	! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
	11	! Public License for more details.
[4227]	12	!
[4680]	13	! You should have received a copy of the GNU General Public License along with PALM. If not, see
	14	! <http://www.gnu.org/licenses/>.
[4227]	15	!
[4360]	16	! Copyright 1997-2020 Leibniz Universitaet Hannover
[4680]	17	!--------------------------------------------------------------------------------------------------!
[4227]	18	!
	19	! Current revisions:
	20	! ------------------
[4680]	21	!
	22	!
[4227]	23	! Former revisions:
	24	! -----------------
	25	! $Id: palm_date_time_mod.f90 4797 2020-11-26 16:02:39Z gronemeier $
[4797]	26	! file re-formatted to follow the PALM coding standard
	27	!
	28	! 4680 2020-09-16 10:20:34Z gronemeier
[4680]	29	! Add option to fix date and time; renamed set_reference_date_time to init_date_time
	30	!
	31	! 4360 2020-01-07 11:25:50Z suehring
[4267]	32	! Add days of northward- and southward equinox
[4680]	33	!
[4267]	34	! 4227 2019-09-10 18:04:34Z gronemeier
[4227]	35	! Complete rework of module date_and_time_mod:
[4797]	36	! - renamed module to prevent confusion with FORTRAN Standard routine date_and_time
[4227]	37	! - introduce date_time_type
	38	! - add set_reference_date_time
	39	! - add get_date_time
	40	! - capsule whole calculation of date and time variables within this routine
	41	! - removed all variables/routines not belonging to this module
	42	!
	43	!
	44	! Authors:
	45	! --------
	46	!> @author Tobias Gronemeier (LUH)
	47	!
	48	! Description:
	49	! ------------
[4797]	50	!> This routine calculates all needed information on date and time used by other modules
[4227]	51	!>
	52	!> @todo Consider leap seconds
[4680]	53	!> @note Time_zone only supports full-hour time zones, i.e., time zones like Australian Central
	54	!> Standard Time (UTC+9.5) are not possible
	55	!--------------------------------------------------------------------------------------------------!
[4227]	56	MODULE palm_date_time_mod
	57
[4680]	58	USE control_parameters, &
[4227]	59	ONLY: message_string
	60
	61	USE kinds
	62
	63	IMPLICIT NONE
	64
	65	!
	66	!-- Parameter Definition
	67	INTEGER(iwp), PARAMETER :: date_time_str_len = 23_iwp !< length of date_time strings
	68	INTEGER(iwp), PARAMETER :: days_per_week = 7_iwp !< days in a week
	69	INTEGER(iwp), PARAMETER :: hours_per_day = 24_iwp !< hours in a day
	70	INTEGER(iwp), PARAMETER :: minutes_per_hour = 60_iwp !< minutes in an hour
	71	INTEGER(iwp), PARAMETER :: months_per_year = 12_iwp !< months in a year
[4267]	72	!
[4680]	73	!-- Day of year of the mean northward and southward equinox (summer and winter half year)
	74	INTEGER(iwp), PARAMETER :: northward_equinox = 80_iwp !< Mar 21 (leap year: Mar 20)
	75	INTEGER(iwp), PARAMETER :: southward_equinox = 264_iwp !< Sep 21 (leap year: Sep 20)
[4227]	76
[4797]	77	CHARACTER(LEN=3), DIMENSION(days_per_week), PARAMETER :: &
[4227]	78	weekdays = (/"Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun"/) !< names of weekdays
	79
[4797]	80	INTEGER, DIMENSION(months_per_year), PARAMETER :: &
[4227]	81	days_per_month_noleapyear = (/31,28,31,30,31,30,31,31,30,31,30,31/) !< days for each month (no leap year)
	82
[4797]	83	INTEGER, DIMENSION(months_per_year), PARAMETER :: &
[4227]	84	days_per_month_leapyear = (/31,29,31,30,31,30,31,31,30,31,30,31/) !< days for each month (leap year)
	85
	86	INTEGER, DIMENSION(121), PARAMETER :: leap_years = & !< list of leap years
[4797]	87	(/ 1804_iwp, 1808_iwp, 1812_iwp, 1816_iwp, 1820_iwp, 1824_iwp, 1828_iwp, 1832_iwp, &
	88	1836_iwp, 1840_iwp, 1844_iwp, 1848_iwp, 1852_iwp, 1856_iwp, 1860_iwp, 1864_iwp, &
	89	1868_iwp, 1872_iwp, 1876_iwp, 1880_iwp, 1884_iwp, 1888_iwp, 1892_iwp, 1896_iwp, &
	90	1904_iwp, 1908_iwp, 1912_iwp, 1916_iwp, 1920_iwp, 1924_iwp, 1928_iwp, 1932_iwp, &
	91	1936_iwp, 1940_iwp, 1944_iwp, 1948_iwp, 1952_iwp, 1956_iwp, 1960_iwp, 1964_iwp, &
	92	1968_iwp, 1972_iwp, 1976_iwp, 1980_iwp, 1984_iwp, 1988_iwp, 1992_iwp, 1996_iwp, &
	93	2000_iwp, 2004_iwp, 2008_iwp, 2012_iwp, 2016_iwp, 2020_iwp, 2024_iwp, 2028_iwp, &
	94	2032_iwp, 2036_iwp, 2040_iwp, 2044_iwp, 2048_iwp, 2052_iwp, 2056_iwp, 2060_iwp, &
	95	2064_iwp, 2068_iwp, 2072_iwp, 2076_iwp, 2080_iwp, 2084_iwp, 2088_iwp, 2092_iwp, &
	96	2096_iwp, 2104_iwp, 2108_iwp, 2112_iwp, 2116_iwp, 2120_iwp, 2124_iwp, 2128_iwp, &
	97	2132_iwp, 2136_iwp, 2140_iwp, 2144_iwp, 2148_iwp, 2152_iwp, 2156_iwp, 2160_iwp, &
	98	2164_iwp, 2168_iwp, 2172_iwp, 2176_iwp, 2180_iwp, 2184_iwp, 2188_iwp, 2192_iwp, &
	99	2196_iwp, 2204_iwp, 2208_iwp, 2212_iwp, 2216_iwp, 2220_iwp, 2224_iwp, 2228_iwp, &
	100	2232_iwp, 2236_iwp, 2240_iwp, 2244_iwp, 2248_iwp, 2252_iwp, 2256_iwp, 2260_iwp, &
	101	2264_iwp, 2268_iwp, 2272_iwp, 2276_iwp, 2280_iwp, 2284_iwp, 2288_iwp, 2292_iwp, &
	102	2296_iwp /)
[4227]	103
[4797]	104	REAL(wp), PARAMETER :: seconds_per_minute = 60.0_wp !< seconds in a minute
	105	REAL(wp), PARAMETER :: seconds_per_hour = seconds_per_minute * minutes_per_hour !< seconds in an hour
	106	REAL(wp), PARAMETER :: seconds_per_day = seconds_per_hour * hours_per_day !< seconds in a day
	107
[4227]	108	!
	109	!-- Type Definition
	110	TYPE date_time_type
	111	INTEGER(iwp) :: year = -HUGE(0_iwp) !< year
	112	INTEGER(iwp) :: month = -HUGE(0_iwp) !< month of year
	113	INTEGER(iwp) :: day = -HUGE(0_iwp) !< day of month
	114	INTEGER(iwp) :: hour = -HUGE(0_iwp) !< hour of day
	115	INTEGER(iwp) :: minute = -HUGE(0_iwp) !< minute of hour
	116	INTEGER(iwp) :: zone = -HUGE(0_iwp) !< time zone
	117
	118	REAL(wp) :: second = -HUGE(0.0_wp) !< second of minute
	119	REAL(wp) :: second_of_year = -HUGE(0.0_wp) !< second of year
	120
	121	INTEGER(iwp) :: days_per_year = -HUGE(0_iwp) !< days within a year
	122
	123	INTEGER, DIMENSION(months_per_year) :: days_per_month = days_per_month_noleapyear !< list of total days per month
	124	END TYPE date_time_type
	125
	126	!
	127	!-- Variable Declaration
[4680]	128	LOGICAL :: date_is_fixed = .FALSE. !< if true, date is fixed (time can still change)
[4227]	129	LOGICAL :: reference_date_time_is_set = .FALSE. !< true if reference_date_time is set
[4680]	130	LOGICAL :: time_is_fixed = .FALSE. !< if true, time does not change at all
[4227]	131
	132	TYPE(date_time_type) :: reference_date_time !< reference date-time
	133
	134	SAVE
	135
	136	PRIVATE
	137	!
	138	!-- Set reference date and time
[4680]	139	INTERFACE init_date_time
	140	MODULE PROCEDURE init_date_time
	141	END INTERFACE init_date_time
[4227]	142	!
	143	!-- Return date and time information
	144	INTERFACE get_date_time
	145	MODULE PROCEDURE get_date_time
	146	END INTERFACE get_date_time
	147	!
	148	!-- Public Interfaces
[4797]	149	PUBLIC &
	150	get_date_time, &
[4680]	151	init_date_time
[4227]	152	!
	153	!-- Public variables
[4797]	154	PUBLIC &
	155	date_time_str_len, &
	156	days_per_week, &
	157	hours_per_day, &
	158	minutes_per_hour, &
	159	months_per_year, &
	160	northward_equinox, &
	161	seconds_per_minute, &
	162	seconds_per_hour, &
	163	seconds_per_day, &
	164	southward_equinox, &
[4227]	165	weekdays
	166
	167	CONTAINS
	168
	169
	170	!--------------------------------------------------------------------------------------------------!
	171	! Description:
	172	! ------------
[4680]	173	!> Initialize date-time setting by defining a global reference date-time and choosing a variable or
	174	!> fixed date.
[4227]	175	!> Only a single call is allowed to this routine during execution.
	176	!--------------------------------------------------------------------------------------------------!
[4680]	177	SUBROUTINE init_date_time( date_time_str, use_fixed_date, use_fixed_time )
[4227]	178
	179	CHARACTER(LEN=date_time_str_len), INTENT(IN) :: date_time_str !< string containing date-time information
	180
[4680]	181	LOGICAL, INTENT(IN), OPTIONAL :: use_fixed_date !< flag to fix date
	182	LOGICAL, INTENT(IN), OPTIONAL :: use_fixed_time !< flag to fix time
[4797]	183
[4227]	184	!
	185	!-- Check if date and time are already set
	186	IF ( reference_date_time_is_set ) THEN
	187	!> @note This error should never be observed by a user.
	188	!> It can only appear if the code was modified.
[4797]	189	WRITE( message_string, * ) 'Multiple calls to init_date_time detected.&' // &
[4680]	190	'This routine must not be called more than once.'
	191	CALL message( 'init_date_time', 'PA0680', 2, 2, 0, 6, 0 )
[4227]	192	RETURN
	193
	194	ELSE
	195
	196	reference_date_time = convert_string_to_date_time( date_time_str )
	197
	198	reference_date_time_is_set = .TRUE.
	199
[4680]	200	IF ( PRESENT( use_fixed_date ) ) date_is_fixed = use_fixed_date
	201	IF ( PRESENT( use_fixed_time ) ) time_is_fixed = use_fixed_time
	202
[4227]	203	ENDIF
	204
[4680]	205	END SUBROUTINE init_date_time
[4227]	206
	207
	208	!--------------------------------------------------------------------------------------------------!
	209	! Description:
	210	! ------------
	211	!> Return requested date-time information of the reference time + time_since_reference.
	212	!> An alternative reference date-time string can be specified via 'reference_date_time_str'.
	213	!> Call to this routine is only possible if a reference time is either specified in the call itself
[4680]	214	!> via 'reference_date_time_str' or previously set by calling routine 'init_date_time'.
[4227]	215	!--------------------------------------------------------------------------------------------------!
[4797]	216	SUBROUTINE get_date_time( time_since_reference, reference_date_time_str, year, month, day, hour, &
	217	minute, second, zone, second_of_day, second_of_year, day_of_year, &
	218	day_of_week, weekday, date_time_str, days_per_month, days_per_year )
[4227]	219
	220	CHARACTER(LEN=date_time_str_len), INTENT(OUT), OPTIONAL :: date_time_str !< date-time as string
	221	CHARACTER(LEN=1) :: plus_minus !< either '+' or '-'
	222	CHARACTER(LEN=date_time_str_len), INTENT(IN), OPTIONAL :: reference_date_time_str !< alternative reference date-time
	223	CHARACTER(LEN=3), INTENT(OUT), OPTIONAL :: weekday !< weekday
	224
[4797]	225	INTEGER(iwp), INTENT(OUT), OPTIONAL :: day !< day of month
	226	INTEGER(iwp), INTENT(OUT), OPTIONAL :: day_of_week !< number of weekday
	227	INTEGER(iwp), INTENT(OUT), OPTIONAL :: day_of_year !< day of the year
	228	INTEGER(iwp), INTENT(OUT), OPTIONAL :: days_per_year !< days per year
	229	INTEGER(iwp), INTENT(OUT), OPTIONAL :: hour !< hour of day
	230	INTEGER(iwp), INTENT(OUT), OPTIONAL :: minute !< minute of hour
	231	INTEGER(iwp), INTENT(OUT), OPTIONAL :: month !< month of year
	232	INTEGER(iwp), INTENT(OUT), OPTIONAL :: year !< year
	233	INTEGER(iwp), INTENT(OUT), OPTIONAL :: zone !< time zone
	234
[4227]	235	INTEGER(iwp), DIMENSION(months_per_year), INTENT(OUT), OPTIONAL :: days_per_month !< days per year
	236
	237	REAL(wp), INTENT(OUT), OPTIONAL :: second !< second of minute
	238	REAL(wp), INTENT(OUT), OPTIONAL :: second_of_day !< second of day
	239	REAL(wp), INTENT(OUT), OPTIONAL :: second_of_year !< second of year
	240	REAL(wp), INTENT(IN) :: time_since_reference !< seconds between reference time and current time
	241
	242	TYPE(date_time_type) :: date_time !< date-time which to return
	243	TYPE(date_time_type) :: internal_reference_date_time !< internal reference date-time
	244
	245	!
	246	!-- Check if a reference date-time is given
	247	IF ( .NOT. reference_date_time_is_set .AND. .NOT. PRESENT( reference_date_time_str ) ) THEN
	248	!> @note This error should never be observed by a user.
	249	!> It can only appear if the code was modified.
[4797]	250	WRITE( message_string, * ) 'No reference date-time defined. '// &
	251	'Returning date-time information is not possible. ' // &
	252	'Either specify reference_date_time_str ' // &
[4680]	253	'or set a reference via init_date_time.'
[4227]	254	CALL message( 'get_date_time', 'PA0677', 2, 2, 0, 6, 0 )
	255	RETURN
	256	ENDIF
	257	!
	258	!-- Set internal reference date-time
	259	IF ( PRESENT( reference_date_time_str ) ) THEN
	260	internal_reference_date_time = convert_string_to_date_time( reference_date_time_str )
	261	ELSE
	262	internal_reference_date_time = reference_date_time
	263	ENDIF
[4680]	264
	265	IF ( time_is_fixed ) THEN
[4227]	266	!
[4680]	267	!-- If time shall not change, set new time to reference time
	268	date_time = internal_reference_date_time
	269	ELSE
[4227]	270	!
[4680]	271	!-- Add time to reference time
	272	date_time = add_date_time( time_since_reference, internal_reference_date_time )
	273	!
	274	!-- If date shall be fixed, revert it to the reference date if changed
	275	IF ( date_is_fixed ) THEN
[4797]	276	IF ( date_time%year /= internal_reference_date_time%year .OR. &
	277	get_day_of_year( date_time ) /= get_day_of_year( internal_reference_date_time ) ) &
[4680]	278	THEN
	279
[4797]	280	date_time%year = internal_reference_date_time%year
	281	date_time%month = internal_reference_date_time%month
	282	date_time%day = internal_reference_date_time%day
	283	date_time = update_leapyear_setting( date_time )
[4680]	284	date_time%second_of_year = get_second_of_year( date_time )
	285
	286	ENDIF
	287	ENDIF
	288	ENDIF
	289	!
[4227]	290	!-- Set requested return values
	291	IF ( PRESENT( year ) ) year = date_time%year
	292	IF ( PRESENT( month ) ) month = date_time%month
	293	IF ( PRESENT( day ) ) day = date_time%day
	294	IF ( PRESENT( hour ) ) hour = date_time%hour
	295	IF ( PRESENT( minute ) ) minute = date_time%minute
	296	IF ( PRESENT( second ) ) second = date_time%second
	297	IF ( PRESENT( zone ) ) zone = date_time%zone
	298	IF ( PRESENT( second_of_year ) ) second_of_year = date_time%second_of_year
	299	IF ( PRESENT( second_of_day ) ) second_of_day = get_second_of_day( date_time )
	300	IF ( PRESENT( day_of_year ) ) day_of_year = get_day_of_year( date_time )
	301	IF ( PRESENT( day_of_week ) ) day_of_week = get_day_of_week( date_time )
	302	IF ( PRESENT( weekday ) ) weekday = weekdays( get_day_of_week( date_time ) )
	303	IF ( PRESENT( days_per_month ) ) days_per_month = date_time%days_per_month
	304	IF ( PRESENT( days_per_year ) ) days_per_year = date_time%days_per_year
	305
	306	IF ( PRESENT( date_time_str ) ) THEN
	307	IF ( date_time%zone < 0_iwp ) THEN
	308	plus_minus = '-'
	309	ELSE
	310	plus_minus = '+'
	311	ENDIF
[4797]	312	WRITE( UNIT = date_time_str, &
	313	FMT = '(I4,"-",I2.2,"-",I2.2,1X,I2.2,":",I2.2,":",I2.2,1X,A1,I2.2)' ) &
	314	date_time%year, date_time%month, date_time%day, &
	315	date_time%hour, date_time%minute, INT( date_time%second ), &
[4227]	316	plus_minus, ABS( date_time%zone )
	317	ENDIF
	318
	319	END SUBROUTINE get_date_time
	320
	321
	322	!--------------------------------------------------------------------------------------------------!
	323	! Description:
	324	! ------------
	325	!> Convert a date-time string into a date_time object.
	326	!--------------------------------------------------------------------------------------------------!
[4797]	327	FUNCTION convert_string_to_date_time( date_time_str ) RESULT( date_time )
[4227]	328
	329	CHARACTER(LEN=date_time_str_len), INTENT(IN) :: date_time_str !< date-time as string
	330
	331	INTEGER(iwp) :: read_status !< returned status of read command
	332
	333	TYPE(date_time_type) :: date_time !< requested date-time object
	334
	335	!
	336	!-- Decompose string to date-time information
	337	READ( UNIT = date_time_str( 1: 4), IOSTAT = read_status, FMT = '(I4)' ) date_time%year
[4797]	338	IF ( read_status == 0 ) THEN
[4227]	339	READ( UNIT = date_time_str( 6: 7), IOSTAT = read_status, FMT = '(I2)' ) date_time%month
[4797]	340	ENDIF
	341	IF ( read_status == 0 ) THEN
[4227]	342	READ( UNIT = date_time_str( 9:10), IOSTAT = read_status, FMT = '(I2)' ) date_time%day
[4797]	343	ENDIF
	344	IF ( read_status == 0 ) THEN
[4227]	345	READ( UNIT = date_time_str(12:13), IOSTAT = read_status, FMT = '(I2)' ) date_time%hour
[4797]	346	ENDIF
	347	IF ( read_status == 0 ) THEN
[4227]	348	READ( UNIT = date_time_str(15:16), IOSTAT = read_status, FMT = '(I2)' ) date_time%minute
[4797]	349	ENDIF
	350	IF ( read_status == 0 ) THEN
[4227]	351	READ( UNIT = date_time_str(18:19), IOSTAT = read_status, FMT = '(F2.0)' ) date_time%second
[4797]	352	ENDIF
	353	IF ( read_status == 0 ) THEN
[4227]	354	READ( UNIT = date_time_str(21:23), IOSTAT = read_status, FMT = '(I3)' ) date_time%zone
[4797]	355	ENDIF
[4227]	356
	357	IF ( read_status /= 0 ) THEN
[4797]	358	WRITE( message_string, * ) 'Error while converting date-time string. ' // &
	359	'Please check format of date-time string: "' // &
	360	TRIM( date_time_str ) // '". ' // &
[4227]	361	'Format must be "YYYY-MM-DD hh:mm:ss ZZZ".'
	362	CALL message( 'convert_string_to_date_time', 'PA0678', 2, 2, 0, 6, 0 )
	363	RETURN
	364	ENDIF
	365
	366	date_time = update_leapyear_setting( date_time )
	367
	368	IF ( check_date( date_time, date_time_str ) == 0 ) THEN
	369
	370	date_time%second_of_year = get_second_of_year( date_time )
	371
	372	!
	373	!-- Shift time to UTC and set zone to UTC
[4797]	374	date_time = add_date_time( REAL( -1 * date_time%zone, KIND = wp ) * seconds_per_hour, &
[4227]	375	date_time )
	376	date_time%zone = 0_iwp
	377	ENDIF
	378
	379	END FUNCTION convert_string_to_date_time
	380
	381
	382	!--------------------------------------------------------------------------------------------------!
	383	! Description:
	384	! ------------
	385	!> Add time increment (in seconds) to given date-time and return shifted date-time
	386	!--------------------------------------------------------------------------------------------------!
	387	FUNCTION add_date_time( inc_seconds, date_time_base ) RESULT( date_time )
	388
	389	INTEGER(iwp) :: i !< loop index
	390
	391	REAL(wp) :: seconds_left !< seconds which must still be added to new date-time
	392	REAL(wp) :: seconds_per_year !< number of seconds in a year
	393
	394	REAL(wp), INTENT(IN) :: inc_seconds !< seconds to be added to date-time
	395
	396	TYPE(date_time_type) :: date_time !< shifted date-time
	397	TYPE(date_time_type), INTENT(IN) :: date_time_base !< date-time to be shifted
	398
	399	!
	400	!-- Define some parameters
	401	date_time = date_time_base
	402	seconds_per_year = REAL( date_time%days_per_year, KIND = wp ) * seconds_per_day
	403	!
	404	!-- Shift time
	405	date_time%second_of_year = date_time%second_of_year + inc_seconds
	406	!
[4797]	407	!-- Check if year changes.
[4227]	408	!-- First, if year is reduced
	409	DO WHILE ( date_time%second_of_year < 0.0_wp )
[4797]	410	date_time%year = date_time%year - 1_iwp
	411	date_time = update_leapyear_setting( date_time )
	412	seconds_per_year = REAL( date_time%days_per_year * seconds_per_day, KIND = wp )
[4227]	413	date_time%second_of_year = date_time%second_of_year + seconds_per_year
	414	ENDDO
	415	!
	416	!-- Now, if year is increased
	417	DO WHILE ( date_time%second_of_year > seconds_per_year )
[4797]	418	date_time%year = date_time%year + 1_iwp
	419	date_time = update_leapyear_setting( date_time )
[4227]	420	date_time%second_of_year = date_time%second_of_year - seconds_per_year
[4797]	421	seconds_per_year = REAL( date_time%days_per_year * seconds_per_day, KIND = wp )
[4227]	422	ENDDO
	423	!
	424	!-- Based on updated year and second_of_year, update month, day, hour, minute, second
	425	DO i = 1, months_per_year
[4797]	426	IF ( date_time%second_of_year < SUM( date_time%days_per_month(1:i) ) * seconds_per_day ) &
[4227]	427	THEN
	428	date_time%month = i
[4797]	429	seconds_left = date_time%second_of_year &
	430	- REAL( SUM( date_time%days_per_month(1:i-1) ), KIND=wp ) &
	431	* seconds_per_day
[4227]	432	date_time%day = INT( seconds_left / seconds_per_day, KIND = iwp ) + 1_iwp
[4797]	433	seconds_left = seconds_left &
	434	- REAL( date_time%day - 1_iwp, KIND = wp ) * seconds_per_day
[4227]	435	date_time%hour = INT( seconds_left / seconds_per_hour, KIND = iwp )
	436	seconds_left = seconds_left - REAL( date_time%hour, KIND = wp ) * seconds_per_hour
	437	date_time%minute = INT( seconds_left / seconds_per_minute, KIND = iwp )
	438	date_time%second = seconds_left - REAL( date_time%minute, KIND = wp ) * seconds_per_minute
	439	EXIT
	440	ENDIF
	441	ENDDO
	442
	443	END FUNCTION add_date_time
	444
	445
	446	!--------------------------------------------------------------------------------------------------!
	447	! Description:
	448	! ------------
	449	!> Return day of year of given date.
	450	!--------------------------------------------------------------------------------------------------!
[4797]	451	FUNCTION get_day_of_year( date_time ) RESULT( day_of_year )
[4227]	452
	453	INTEGER(iwp) :: day_of_year !< day of the year
	454
	455	TYPE(date_time_type), INTENT(IN) :: date_time !< date of which to calculate day of year
	456	TYPE(date_time_type) :: date_time_internal !< internal copy of input date-time
	457
	458
	459	date_time_internal = update_leapyear_setting( date_time )
	460
	461	day_of_year = date_time_internal%day &
	462	+ SUM( date_time_internal%days_per_month(:date_time_internal%month-1) )
	463
	464	END FUNCTION get_day_of_year
	465
	466
	467	!--------------------------------------------------------------------------------------------------!
	468	! Description:
	469	! ------------
	470	!> Return second of day of given time.
	471	!--------------------------------------------------------------------------------------------------!
[4797]	472	FUNCTION get_second_of_day( date_time ) RESULT( second_of_day )
[4227]	473
	474	REAL(wp) :: second_of_day !< second of the day
	475
	476	TYPE(date_time_type), INTENT(IN) :: date_time !< date of which to calculate second of the day
	477
	478
[4797]	479	second_of_day = date_time%second &
	480	+ REAL( ( date_time%hour * minutes_per_hour ) + date_time%minute, KIND = wp ) &
	481	* seconds_per_minute
[4227]	482
	483	END FUNCTION get_second_of_day
	484
	485
	486	!--------------------------------------------------------------------------------------------------!
	487	! Description:
	488	! ------------
	489	!> Return second of year of given date-time.
	490	!--------------------------------------------------------------------------------------------------!
[4797]	491	FUNCTION get_second_of_year( date_time ) RESULT( second_of_year )
[4227]	492
	493	REAL(wp) :: second_of_year !< second of the year
	494
	495	TYPE(date_time_type), INTENT(IN) :: date_time !< date of which to calculate second of the year
	496
	497
[4797]	498	second_of_year = get_second_of_day( date_time ) &
	499	+ REAL( get_day_of_year( date_time ) - 1_iwp, KIND = wp ) * seconds_per_day
[4227]	500
	501	END FUNCTION get_second_of_year
	502
	503
	504	!--------------------------------------------------------------------------------------------------!
	505	! Description:
	506	! ------------
	507	!> Return index of the day of the week of the given date-time.
	508	!--------------------------------------------------------------------------------------------------!
[4797]	509	FUNCTION get_day_of_week( date_time_in ) RESULT( day_of_week )
[4227]	510
	511	INTEGER(iwp) :: day_difference !< day between given date and reference
	512	INTEGER(iwp) :: day_of_week !< day of the week
[4797]	513	INTEGER(iwp) :: date_time_internal_reference_day_of_week !< day of week of reference date
[4227]	514
	515	TYPE(date_time_type), INTENT(IN) :: date_time_in !< date of which to get the weekday
	516	TYPE(date_time_type) :: date_time_internal !< internal date-time
	517
	518	!
	519	!-- Define reference date from which on the current day of week can be determined
	520	date_time_internal%year = 2000_iwp
	521	date_time_internal%month = 1_iwp
	522	date_time_internal%day = 1_iwp
	523	date_time_internal_reference_day_of_week = 6_iwp
	524
	525	!
	526	!-- First, get the difference if both dates would be in the same year
	527	day_difference = get_day_of_year( date_time_in ) - get_day_of_year( date_time_internal )
	528	!
	529	!-- Now, shift the year and add the corresponding number of days to the difference
	530	IF ( date_time_internal%year < date_time_in%year ) THEN
	531
	532	DO WHILE ( date_time_internal%year /= date_time_in%year )
	533
	534	date_time_internal = update_leapyear_setting( date_time_internal )
	535	day_difference = day_difference + date_time_internal%days_per_year
	536
	537	date_time_internal%year = date_time_internal%year + 1_iwp
	538
	539	ENDDO
	540
	541	ELSEIF ( date_time_internal%year > date_time_in%year ) THEN
	542
	543	DO WHILE ( date_time_internal%year /= date_time_in%year )
	544
	545	date_time_internal%year = date_time_internal%year - 1_iwp
	546
	547	date_time_internal = update_leapyear_setting( date_time_internal )
	548	day_difference = day_difference - date_time_internal%days_per_year
	549
	550	ENDDO
	551
	552	ENDIF
	553	!
[4797]	554	!-- Remove full weeks of day_difference and shift day_of_week of reference by remaining days.
[4227]	555	day_of_week = date_time_internal_reference_day_of_week + MOD( day_difference, days_per_week )
	556
	557	IF ( day_of_week > days_per_week ) THEN
	558	!
	559	!-- Shift index again if it is next week (above days_per_week)...
	560	day_of_week = day_of_week - days_per_week
	561	ELSEIF ( day_of_week <= 0_iwp ) THEN
	562	!
	563	!-- ...or if it is last week (below 1)
	564	day_of_week = day_of_week + days_per_week
	565	ENDIF
	566
	567	END FUNCTION get_day_of_week
	568
	569
	570	!--------------------------------------------------------------------------------------------------!
	571	! Description:
	572	! ------------
	573	!> Check if given year is a leap year and update days per month accordingly.
	574	!--------------------------------------------------------------------------------------------------!
[4797]	575	FUNCTION update_leapyear_setting( date_time_in ) RESULT( date_time_out )
[4227]	576
	577	TYPE(date_time_type), INTENT(IN) :: date_time_in !< input date-time
	578	TYPE(date_time_type) :: date_time_out !< return date-time
	579
	580
	581	date_time_out = date_time_in
	582
	583	IF ( ANY( date_time_in%year == leap_years ) ) THEN
	584	date_time_out%days_per_month = days_per_month_leapyear
	585	ELSE
	586	date_time_out%days_per_month = days_per_month_noleapyear
	587	ENDIF
	588
	589	date_time_out%days_per_year = SUM( date_time_out%days_per_month )
	590
	591	END FUNCTION update_leapyear_setting
	592
	593
	594	!--------------------------------------------------------------------------------------------------!
	595	! Description:
	596	! ------------
	597	!> Check if given date and time are valid. Returns 0 if all checks are passed.
[4797]	598	!> @todo Revise error message. ATM, gives only last errorneous value even if multiple values violate
	599	!> the bounds.
[4227]	600	!--------------------------------------------------------------------------------------------------!
[4797]	601	FUNCTION check_date( date_time, date_time_str ) RESULT( error_code )
[4227]	602
	603
	604	CHARACTER(LEN=6), DIMENSION(7), PARAMETER :: error_str_list = & !< string used for error message
	605	(/'year ', 'month ', 'day ', 'hour ', 'minute', 'second', 'zone '/)
	606
	607	CHARACTER(LEN=date_time_str_len), INTENT(IN) :: date_time_str !< date-time as string
	608
	609	INTEGER(iwp) :: error_code !< error code
	610
	611	TYPE(date_time_type), INTENT(IN) :: date_time !< date-time to be checked
	612
	613
	614	error_code = 0
	615	!
	616	!-- Check date
[4797]	617	IF ( date_time%month < 1_iwp .OR. date_time%month > months_per_year ) THEN
[4227]	618	error_code = 2
	619	ELSE
[4797]	620	IF ( date_time%day < 1_iwp .OR. &
[4227]	621	date_time%day > date_time%days_per_month(date_time%month) ) THEN
	622	error_code = 3
	623	ENDIF
	624	ENDIF
	625	!
	626	!-- Check time
[4797]	627	IF ( date_time%hour < 0_iwp .OR. date_time%hour > hours_per_day ) THEN
[4227]	628	error_code = 4
	629	ELSE
[4797]	630	IF ( date_time%minute < 0_iwp .OR. date_time%minute > minutes_per_hour ) THEN
[4227]	631	error_code = 5
	632	ELSE
[4797]	633	IF ( date_time%second < 0.0_wp .OR. date_time%second >= seconds_per_minute ) THEN
[4227]	634	error_code = 6
	635	ENDIF
	636	ENDIF
	637	ENDIF
	638	!
[4797]	639	!-- Check time zone.
[4227]	640	!-- Bounds defined by maximum and minimum time zone present on earth
[4797]	641	IF ( date_time%zone < -12_iwp .OR. date_time%zone > 14_iwp ) THEN
[4227]	642	error_code = 7
	643	ENDIF
	644	!
	645	!-- Raise error if any check is marked invalid
	646	IF ( error_code /= 0 ) THEN
[4797]	647	WRITE( message_string, * ) 'Date-time values out of bounds: "' // &
	648	TRIM( error_str_list(error_code) ) // &
	649	'" is out of bounds. Please check date-time string: "' // &
	650	TRIM( date_time_str ) // '". ' // &
[4227]	651	'Format must be "YYYY-MM-DD hh:mm:ss ZZZ".'
	652	CALL message( 'check_date', 'PA0679', 2, 2, 0, 6, 0 )
	653	RETURN
	654	ENDIF
	655
	656	END FUNCTION check_date
	657
	658	END MODULE palm_date_time_mod

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |