Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This include file contains procedure implementations of [pm_dateTime](@ref pm_dateTime).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, March 23, 2012, 5:33 PM, National Institute for Fusion Studies, The University of Texas at Austin
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !%%%%%%%%%%%%%%%%%%
28 : #if isValidZone_ENABLED
29 : !%%%%%%%%%%%%%%%%%%
30 :
31 295524 : isValid = logical(int(ZONE_MIN, IKC) <= zone .and. zone <= int(ZONE_MAX, IKC), LK)
32 :
33 : !%%%%%%%%%%%%%%%%%%%%%%
34 : #elif getDateTimeDiff_ENABLED
35 : !%%%%%%%%%%%%%%%%%%%%%%
36 :
37 : CHECK_ASSERTION(__LINE__, size(Values1, kind = IK) == 8_IK, SK_"@getDateTimeDiff(): The condition `size(Values1) == 8` must hold. size(Values1) = "//getStr(size(Values1, kind = IK)))
38 : CHECK_ASSERTION(__LINE__, size(Values2, kind = IK) == 8_IK, SK_"@getDateTimeDiff(): The condition `size(Values2) == 8` must hold. size(Values2) = "//getStr(size(Values2, kind = IK)))
39 : if (Values1(4) == Values2(4)) then ! identical timezone.
40 : dateTimeDiff= getJulianDay(Values1(1), Values1(2), Values1(3), 0_IK, Values1(5), Values1(6), Values1(7), Values1(8)) & ! LCOV_EXCL_LINE
41 : - getJulianDay(Values2(1), Values2(2), Values2(3), 0_IK, Values2(5), Values2(6), Values2(7), Values2(8))
42 : else ! different timezones.
43 : dateTimeDiff= getJulianDay(Values1(1), Values1(2), Values1(3), Values1(4), Values1(5), Values1(6), Values1(7), Values1(8)) & ! LCOV_EXCL_LINE
44 : - getJulianDay(Values2(1), Values2(2), Values2(3), Values2(4), Values2(5), Values2(6), Values2(7), Values2(8))
45 : end if
46 :
47 : !%%%%%%%%%%%%%%%%%%%%%%
48 : #elif isValidDateTime_ENABLED
49 : !%%%%%%%%%%%%%%%%%%%%%%
50 :
51 : #if isValidDateTimeV_ENABLED
52 : integer(IK) :: lenValues
53 2213 : lenValues = size(values, 1, IK)
54 2213 : if (lenValues == 8_IK) then
55 201 : isValid = isValidDateTime(values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
56 : elseif (lenValues == 7_IK) then
57 201 : isValid = isValidDateTime(values(1), values(2), values(3), values(4), values(5), values(6), values(7))
58 : elseif (lenValues == 6_IK) then
59 201 : isValid = isValidDateTime(values(1), values(2), values(3), values(4), values(5), values(6))
60 : elseif (lenValues == 5_IK) then
61 201 : isValid = isValidDateTime(values(1), values(2), values(3), values(4), values(5))
62 : elseif (lenValues == 4_IK) then
63 201 : isValid = isValidDateTime(values(1), values(2), values(3), values(4))
64 : elseif (lenValues == 3_IK) then
65 201 : isValid = isValidDateTime(values(1), values(2), values(3))
66 : elseif (lenValues == 2_IK) then
67 201 : isValid = isValidDateTime(values(1), values(2))
68 : elseif (lenValues == 1_IK) then
69 201 : isValid = isValidDateTime(values(1))
70 : else
71 : isValid = .false._LK
72 : !error stop MODULE_NAME//SK_"@isValidDateTime(): The length of the input argument `values` must be less than 9 and non-zero. size(values) = "//getStr(lenValues)
73 : end if
74 : #elif isValidDateTimeY_ENABLED
75 : isValid = .true._LK ! year /= 0_IKC ! year zero is explicitly allowed in ISO 8601.
76 : #elif isValidDateTimeYM_ENABLED
77 570043 : isValid = isValidDateTime(year) .and. 0_IKC < month .and. month < 13_IKC
78 : #elif isValidDateTimeYMD_ENABLED
79 567533 : isValid = isValidDateTime(year, month) .and. day > 0_IKC
80 : if (isValid) then
81 567533 : if (isLeapYear(year)) then
82 393870 : isValid = day <= DAYS_OF_MONTH_LEAP(month)
83 : else
84 173663 : isValid = day <= DAYS_OF_MONTH(month)
85 : end if
86 : end if
87 : #elif isValidDateTimeYMDZ_ENABLED
88 282565 : isValid = isValidDateTime(year, month, day) .and. isValidZone(zone)
89 : #elif isValidDateTimeYMDZH_ENABLED
90 282164 : isValid = isValidDateTime(year, month, day, zone) .and. 0_IKC <= hour .and. hour < 24_IKC
91 : #elif isValidDateTimeYMDZHM_ENABLED
92 281763 : isValid = isValidDateTime(year, month, day, zone, hour) .and. 0_IKC <= minute .and. minute < 60_IKC
93 : #elif isValidDateTimeYMDZHMS_ENABLED
94 281362 : isValid = isValidDateTime(year, month, day, zone, hour, minute) .and. 0_IKC <= second .and. second < 60_IKC
95 : #elif isValidDateTimeYMDZHMSM_ENABLED
96 280961 : isValid = isValidDateTime(year, month, day, zone, hour, minute, second) .and. 0_IKC <= millisecond .and. millisecond < 1000_IKC
97 : #else
98 : #error "Unrecognized interface."
99 : #endif
100 :
101 : !%%%%%%%%%%%%%%%%%%%%%%%%
102 : #elif getDateTimeValues_ENABLED
103 : !%%%%%%%%%%%%%%%%%%%%%%%%
104 :
105 : #if getDateTimeValuesJ_ENABLED
106 : real(RKC) , parameter :: K1 = 0.25_RKC ! The condition `0.002929687499688476 < K1 <= 0.2521972656249999` must hold.
107 : real(RKC) , parameter :: K2 = 0.25_RKC ! The condition `0. < K2 <= 0.25` must hold.
108 : real(RKC) , parameter :: MEAN_YEAR = 365.25_RKC
109 : real(RKC) , parameter :: MEAN_YEAR_INVERSE = 1._RKC / MEAN_YEAR
110 : real(RKC) , parameter :: WHOLE_CENTURY_FACTOR = 1._RKC / 36524.25_RKC
111 : integer(IKC), parameter :: DAYS_IN_PAST_MONTHS(3:14) = [0_IKC, 31_IKC, 61_IKC, 92_IKC, 122_IKC, 153_IKC, 184_IKC, 214_IKC, 245_IKC, 275_IKC, 306_IKC, 337_IKC] ! last two correspond to jan, feb.
112 : integer(IKC) :: julianDayOffset_IK ! Z
113 : integer(IKC) :: fullCenturyCount
114 : integer(IKC) :: dayOfYearTerm
115 : real(RKC) :: hours_RK
116 : real(RKC) :: minutes_RK
117 : real(RKC) :: seconds_RK
118 : real(RKC) :: julianDayOffset_RK
119 : real(RKC) :: julianDayOffsetResidual ! R
120 : real(RKC) :: daysInWholeCenturyMinusConst ! B
121 119016 : julianDayOffset_RK = julianDay - 1721118.5_RKC
122 119016 : julianDayOffset_IK = floor(julianDayOffset_RK, IKC) ! Z
123 119016 : julianDayOffsetResidual = julianDayOffset_RK - real(julianDayOffset_IK, RKC) ! R : always positive
124 119016 : fullCenturyCount = floor((real(julianDayOffset_IK, RKC) - K1) * WHOLE_CENTURY_FACTOR, IKC) ! A
125 119016 : dayOfYearTerm = julianDayOffset_IK + fullCenturyCount - floor(fullCenturyCount * 0.25_RKC, IKC) ! Z + A - floor(A/4)
126 119016 : daysInWholeCenturyMinusConst = dayOfYearTerm - K2 ! B
127 119016 : values(1) = floor(daysInWholeCenturyMinusConst * MEAN_YEAR_INVERSE, IKC) ! Y : Calendar Year Starting March.
128 119016 : values(3) = dayOfYearTerm - floor(values(1) * MEAN_YEAR, IKC) ! C : Day Of Year.
129 119016 : values(2) = (5_IKC * values(3) + 456_IKC) / 153_IKC ! M : Month Of Year in the range 3:14.
130 119016 : values(3) = values(3) - DAYS_IN_PAST_MONTHS(values(2)) !+ int(julianDayOffsetResidual, IKC)
131 : !if (julianDayOffsetResidual > 1._RKC) error stop getStr(julianDayOffsetResidual)
132 119016 : if (values(2) > 12_IKC) then
133 10958 : values(1) = values(1) + 1_IKC
134 10958 : values(2) = values(2) - 12_IKC
135 : end if
136 119016 : values(4) = 0_IKC
137 119016 : hours_RK = julianDayOffsetResidual * 24._RKC
138 119016 : values(5) = int(hours_RK, IKC)
139 : !if (values(5) < 0_IKC) then
140 : ! values(1:3) = getDateBefore(values(1), values(2), values(3))
141 : ! values(5) = 24_IKC - values(5)
142 : !end if
143 119016 : minutes_RK = (hours_RK - values(5)) * 60._RKC
144 119016 : values(6) = int(minutes_RK, IKC)
145 119016 : seconds_RK = (minutes_RK - values(6)) * 60._RKC
146 119016 : values(7) = int(seconds_RK, IKC)
147 119016 : values(8) = nint((seconds_RK - values(7)) * 1000._RKC, IKC)
148 119016 : if (values(8) == 1000_IKC) then
149 24734 : values(8) = 0_IKC
150 24734 : values(7) = values(7) + 1_IKC
151 24734 : if (values(7) == 60_IKC) then
152 18175 : values(7) = 0_IKC
153 18175 : values(6) = values(6) + 1_IKC
154 18175 : if (values(6) == 60_IKC) then
155 225 : values(6) = 0_IKC
156 225 : values(5) = values(5) + 1_IKC
157 : end if
158 18175 : if (values(5) == 24_IKC) then
159 0 : values(5) = 0_IKC
160 0 : values(1:3) = getDateAfter(values(1), values(2), values(3))
161 : end if
162 : end if
163 : end if
164 : #elif getDateTimeValuesJZ_ENABLED
165 1500 : values(1:8) = getDateTimeNewZone(zone, getDateTime(julianDay))
166 : #elif getDateTimeValuesC_ENABLED
167 15550 : call date_and_time(values = values)
168 : !integer(IK) :: lenValues
169 : !integer(IKC) :: Values_(8)
170 : !lenValues = size(values, 1, IK)
171 : !CHECK_ASSERTION(__LINE__, 0_IK < lenValues .and. lenValues < 9_IK, SK_"@getDateTime(): The input argument `values` must have a non-zero size that is less than 9. size(values) = "//getStr(lenValues)) ! fpp
172 : !if (lenValues > 7_IK) then
173 : ! call date_and_time(values = values)
174 : !else
175 : ! call date_and_time(values = Values_)
176 : ! values(1:lenValues) = Values_(1:lenValues)
177 : !end if
178 : !CHECK_ASSERTION(__LINE__, all(values(1:lenValues) /= -huge(0_IKC)), SK_"@getDateTime(): The processor does not have a clock.") ! fpp
179 : #elif getDateTimeValuesY_ENABLED
180 10509 : values(1) = year
181 10509 : values(2) = 1_IKC
182 10509 : values(3) = 1_IKC
183 63054 : values(4:8) = 0_IKC
184 : #elif getDateTimeValuesYM_ENABLED
185 501 : values(1) = year
186 501 : values(2) = month
187 501 : values(3) = 1_IKC
188 3006 : values(4:8) = 0_IKC
189 : #elif getDateTimeValuesYMD_ENABLED
190 536 : values(1) = year
191 536 : values(2) = month
192 536 : values(3) = day
193 3216 : values(4:8) = 0_IKC
194 : #elif getDateTimeValuesYMDZ_ENABLED
195 521 : values(1) = year
196 521 : values(2) = month
197 521 : values(3) = day
198 521 : values(4) = zone
199 2605 : values(5:8) = 0_IKC
200 : #elif getDateTimeValuesYMDZH_ENABLED
201 504 : values(1) = year
202 504 : values(2) = month
203 504 : values(3) = day
204 504 : values(4) = zone
205 504 : values(5) = hour
206 2016 : values(6:8) = 0_IKC
207 : #elif getDateTimeValuesYMDZHM_ENABLED
208 502 : values(1) = year
209 502 : values(2) = month
210 502 : values(3) = day
211 502 : values(4) = zone
212 502 : values(5) = hour
213 502 : values(6) = minute
214 1506 : values(7:8) = 0_IKC
215 : #elif getDateTimeValuesYMDZHMS_ENABLED
216 501 : values(1) = year
217 501 : values(2) = month
218 501 : values(3) = day
219 501 : values(4) = zone
220 501 : values(5) = hour
221 501 : values(6) = minute
222 501 : values(7) = second
223 501 : values(8) = 0_IKC
224 : #elif getDateTimeValuesYMDZHMSM_ENABLED
225 502 : values(1) = year
226 502 : values(2) = month
227 502 : values(3) = day
228 502 : values(4) = zone
229 502 : values(5) = hour
230 502 : values(6) = minute
231 502 : values(7) = second
232 502 : values(8) = millisecond
233 : #else
234 : #error "Unrecognized interface."
235 : #endif
236 :
237 : !%%%%%%%%%%%%%%%%%%%%%%%%
238 : #elif getDateTimeString_ENABLED
239 : !%%%%%%%%%%%%%%%%%%%%%%%%
240 :
241 : #define RESIZE_STRING(LENSEG) \
242 : eposnew = epos + LENSEG; \
243 : if (eposnew > lenString) then; \
244 : if (allocated(tempstr)) deallocate(tempstr); \
245 : allocate(character(eposnew,SKC) :: tempstr); \
246 : tempstr(1:lenString) = string; \
247 : call move_alloc(tempstr, string); \
248 : lenString = eposnew; \
249 : end if;
250 :
251 : #if getDateTimeStringC_ENABLED
252 : integer(IKC) :: values(8)
253 113 : call date_and_time(values = values)
254 113 : string = getDateTime(format, values)
255 : #elif getDateTimeStringV_ENABLED
256 : !> \warning
257 : !> The output of getStr() in this procedure is of kind \SK which is incompatible with any value of SKC /= SK.
258 : !> For now, this is not an issue since both kinds point to the default character kind.
259 : !> This will however become an issue once Fortran standard and compilers support non-default date and time characters.
260 : use pm_val2str, only: getStr
261 : character(:,SKC), allocatable :: tempstr, abbr
262 : !character(1,SKC) :: sep
263 : !character(28,SKC) :: workspace
264 : character(9,SKC) :: workspace9
265 : integer(IK) :: lenString, lenFormat, i, epos, eposnew, lenSeg
266 : integer(IKC) :: century!, WeekDate(3)
267 20138 : allocate(character(127,SKC) :: string)
268 20138 : lenFormat = len(format, IK)
269 : lenString = 127_IK
270 : eposnew = 0_IK ! the last touched (end) position in the string
271 : i = 0_IK
272 20138 : CHECK_ASSERTION(__LINE__, 0 < size(values) .and. size(values) < 9, SK_"@getDateTime(): The condition `0 < size(values) .and. size(values) < 9` must hold. size(values) = "//getStr(size(values))) ! fpp
273 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 1, .true., \
274 : index(format, "%b") > 0 .or. \
275 : index(format, "%B") > 0 .or. \
276 : index(format, "%h") > 0 .or. \
277 : index(format, "%m") > 0 .or. \
278 : index(format, "%y") > 0 \
279 : ), SK_"@getDateTime(): The condition `size(values) > 1` must hold. size(values) = "//getStr(size(values))) ! fpp
280 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 2, .true., \
281 : index(format, "%a") > 0 .or. \
282 : index(format, "%A") > 0 .or. \
283 : index(format, "%d") > 0 .or. \
284 : index(format, "%D") > 0 .or. \
285 : index(format, "%e") > 0 .or. \
286 : index(format, "%g") > 0 .or. \
287 : index(format, "%G") > 0 .or. \
288 : index(format, "%j") > 0 .or. \
289 : index(format, "%u") > 0 .or. \
290 : index(format, "%U") > 0 .or. \
291 : index(format, "%V") > 0 .or. \
292 : index(format, "%w") > 0 .or. \
293 : index(format, "%W") > 0 .or. \
294 : index(format, "%x") > 0 \
295 : ), SK_"@getDateTime(): The condition `size(values) > 2` must hold. size(values) = "//getStr(size(values))) ! fpp
296 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 3, .true., \
297 : index(format, "%z") > 0 .or. \
298 : index(format, "%Z") > 0 \
299 : ), SK_"@getDateTime(): The condition `size(values) > 4` must hold. size(values) = "//getStr(size(values))) ! fpp
300 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 4, .true., \
301 : index(format, "%H") > 0 .or. \
302 : index(format, "%I") > 0 .or. \
303 : index(format, "%p") > 0 \
304 : ), SK_"@getDateTime(): The condition `size(values) > 4` must hold. size(values) = "//getStr(size(values))) ! fpp
305 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 5, .true., \
306 : index(format, "%M") > 0 .or. \
307 : index(format, "%R") > 0 \
308 : ), SK_"@getDateTime(): The condition `size(values) > 5` must hold. size(values) = "//getStr(size(values))) ! fpp
309 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 6, .true., \
310 : index(format, "%c") > 0 .or. \
311 : index(format, "%r") > 0 .or. \
312 : index(format, "%S") > 0 .or. \
313 : index(format, "%T") > 0 .or. \
314 : index(format, "%X") > 0 \
315 : ), SK_"@getDateTime(): The condition `size(values) > 6` must hold. size(values) = "//getStr(size(values))) ! fpp
316 20138 : CHECK_ASSERTION(__LINE__, merge(size(values) > 7, .true., index(format, "%f") > 0), SK_"@getDateTime(): The condition `size(values) > 7` must hold. size(values) = "//getStr(size(values))) ! fpp
317 : do
318 56676 : i = i + 1_IK
319 56676 : if (i > lenFormat) exit
320 : epos = eposnew
321 56676 : if (format(i:i) == SKC_"%") then
322 24558 : if (i == lenFormat) exit
323 24558 : i = i + 1_IK
324 24558 : if (format(i:i) == SKC_"a") then ! Abbreviated weekday name *
325 : lenSeg = 3_IK
326 508 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
327 508 : string(epos + 1 : eposnew) = WEEKDAY_NAME_ISO(getWeekDayISO(values(1), values(2), values(3)))(1:lenSeg)
328 : elseif (format(i:i) == SKC_"A") then ! Full weekday name *
329 516 : workspace9 = WEEKDAY_NAME_ISO(getWeekDayISO(values(1), values(2), values(3)))
330 516 : lenSeg = len_trim(workspace9, IKC)
331 516 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
332 516 : string(epos + 1 : eposnew) = workspace9(1:lenSeg)
333 : elseif (format(i:i) == SKC_"b" .or. format(i:i) == SKC_"h") then ! Abbreviated month name * .or. Abbreviated month name * (same as %b)
334 : lenSeg = 3_IK
335 1155 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
336 1155 : string(epos + 1 : eposnew) = MONTH_NAME(values(2))(1:lenSeg)
337 : elseif (format(i:i) == SKC_"B") then ! Full month name *
338 537 : lenSeg = len_trim(MONTH_NAME(values(2)), IKC)
339 537 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
340 537 : string(epos + 1 : eposnew) = MONTH_NAME(values(2))(1:lenSeg)
341 : elseif (format(i:i) == SKC_"c") then ! Date and time representation *
342 570 : if (values(1) > 0_IKC) then
343 28 : RESIZE_STRING(24_IK) ! fpp sets eposnew, and resizes string.
344 : else
345 542 : RESIZE_STRING(25_IK) ! fpp sets eposnew, and resizes string.
346 : end if
347 : string(epos + 1 : eposnew) = WEEKDAY_NAME_ISO(getWeekDayISO(values(1), values(2), values(3)))(1:3)//SKC_" "// & ! LCOV_EXCL_LINE
348 : MONTH_NAME(values(2))(1:3)//SKC_" "// & ! LCOV_EXCL_LINE
349 : getStr(values(3), length = 2_IK, format = "(1I0.2)")//SKC_" "// & ! LCOV_EXCL_LINE
350 : getStr(values(5), length = 2_IK, format = "(1I0.2)")//SKC_":"// & ! LCOV_EXCL_LINE
351 : getStr(values(6), length = 2_IK, format = "(1I0.2)")//SKC_":"// & ! LCOV_EXCL_LINE
352 : getStr(values(7), length = 2_IK, format = "(1I0.2)")//SKC_" "// & ! LCOV_EXCL_LINE
353 : !getStr(values(7), length = 2_IK, format = "(1I0.2)")//SKC_"."// & ! LCOV_EXCL_LINE
354 : !getStr(values(8), length = 3_IK, format = "(1I0.3)")//SKC_" "// & ! LCOV_EXCL_LINE
355 570 : getStr(values(1))
356 : elseif (format(i:i) == SKC_"C") then ! Year divided by 100 and truncated to integer (00-99). \warning it works for years up to 9 digits.
357 1054 : century = floor(values(1) / 100., IKC)
358 1054 : if (abs(century) < 100_IKC) then
359 : !write(workspace9(1:3), "(sp,I0.2)") century
360 553 : RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
361 553 : write(string(epos + 1 : eposnew), "(sp,I0.2)") century
362 : else
363 501 : workspace9 = getStr(century)
364 501 : lenSeg = len_trim(workspace9, IKC)
365 501 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
366 501 : string(epos + 1 : eposnew) = workspace9(1:lenSeg)
367 : end if
368 : elseif (format(i:i) == SKC_"d") then ! Day of the month, zero-padded (01-31).
369 567 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
370 567 : write(string(epos + 1 : eposnew), "(I0.2)") values(3)
371 : elseif (format(i:i) == SKC_"D") then ! Short MM/DD/YY date, equivalent to %m/%d/%y
372 577 : RESIZE_STRING(8_IK) ! fpp sets eposnew, and resizes string.
373 : !write(workspace9(1:2), "(I0.2)") values(2) ! month.
374 : !write(workspace9(3:4), "(I0.2)") values(3) ! day.
375 : !write(workspace9(5:6), "(I0.2)") mod(abs(values(1)), 100_IKC) ! last two digits of year.
376 : !string(epos + 1 : eposnew) = workspace9(1:2)//sep// & ! LCOV_EXCL_LINE
377 : ! workspace9(3:4)//sep// & ! LCOV_EXCL_LINE
378 : ! workspace9(5:6)
379 577 : write(string(epos + 1 : eposnew), "(I0.2,'/',I0.2,'/',I0.2)") values(2:3), mod(abs(values(1)), 100_IKC) ! last two digits of year.
380 : elseif (format(i:i) == SKC_"e") then ! Day of the month, zero-padded (01-31).
381 591 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
382 591 : write(string(epos + 1 : eposnew), "(I2)") values(3)
383 : elseif (format(i:i) == SKC_"f") then ! millisecond padded with leading zeros
384 609 : RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
385 609 : write(string(epos + 1 : eposnew), "(I0.3)") values(8)
386 : elseif (format(i:i) == SKC_"F") then ! Short YYYY-MM-DD date, equivalent to %Y-%m-%d
387 606 : if (values(1) > 0_IKC) then
388 1 : RESIZE_STRING(10_IK) ! fpp sets eposnew, and resizes string.
389 : else
390 605 : RESIZE_STRING(11_IK) ! fpp sets eposnew, and resizes string.
391 : end if
392 606 : write(string(epos + 1 : eposnew), "(I0.2,'-',I0.2,'-',I0.2)") values(1:3)
393 : elseif (format(i:i) == SKC_"g") then ! Week-based year, last two digits (00-99).
394 : !WeekDate(1:3) = getWeekDate(values(1:3))
395 619 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
396 619 : write(string(epos + 1 : eposnew), "(I0.2)") mod(abs(getWeekYear(values(1:3))), 100_IKC) ! last two digits of the week year.
397 : elseif (format(i:i) == SKC_"G") then ! Week-based year, full week year, possibly negative.
398 : !WeekDate(1:3) = getWeekDate(values(1:3))
399 624 : workspace9 = getStr(getWeekYear(values(1:3))) ! WeekDate(1)) ! full week year, possibly negative.
400 624 : lenSeg = len_trim(workspace9, IKC)
401 624 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
402 624 : string(epos + 1 : eposnew) = workspace9(1:lenSeg)
403 : elseif (format(i:i) == SKC_"H") then ! Hour in 24h format (00-23)
404 642 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
405 642 : write(string(epos + 1 : eposnew), "(I0.2)") values(5)
406 : elseif (format(i:i) == SKC_"I") then ! Hour in 12h format (01-12)
407 649 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
408 649 : write(string(epos + 1 : eposnew), "(I0.2)") getHour12(values(5))
409 : !if (values(5) < 12_IKC) then
410 : ! write(string(epos + 1 : eposnew), "(I0.2)") values(5)
411 : !else
412 : ! write(string(epos + 1 : eposnew), "(I0.2)") values(5) - 12_IKC
413 : !end if
414 : elseif (format(i:i) == SKC_"j") then ! Day of the year (001-366)
415 662 : RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
416 662 : write(string(epos + 1 : eposnew), "(I0.3)") getOrdinalDay(values(1:3))
417 : elseif (format(i:i) == SKC_"m") then ! Month as a decimal number (01-12)
418 681 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
419 681 : write(string(epos + 1 : eposnew), "(I0.2)") values(2)
420 : elseif (format(i:i) == SKC_"M") then ! Minute (00-59)
421 670 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
422 670 : write(string(epos + 1 : eposnew), "(I0.2)") values(6)
423 : elseif (format(i:i) == SKC_"n") then ! New-line character ('\n')
424 674 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
425 674 : string(epos + 1 : eposnew) = achar(10, SKC) ! new_line(SKC_"a")
426 : elseif (format(i:i) == SKC_"p") then ! AM or PM designation
427 677 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
428 677 : if (values(5) < 12_IKC) then
429 339 : string(epos + 1 : eposnew) = SKC_"AM"
430 : else
431 338 : string(epos + 1 : eposnew) = SKC_"PM"
432 : end if
433 : elseif (format(i:i) == SKC_"r") then ! 12-hour clock time *
434 690 : RESIZE_STRING(11_IK) ! fpp sets eposnew, and resizes string.
435 690 : if (values(5) < 12_IKC) then
436 335 : write(string(epos + 1 : eposnew), "(I0.2,':',I0.2,':',I0.2,' am')") getHour12(values(5)), values(6:7)
437 : else
438 355 : write(string(epos + 1 : eposnew), "(I0.2,':',I0.2,':',I0.2,' pm')") getHour12(values(5)), values(6:7)
439 : end if
440 : elseif (format(i:i) == SKC_"R") then ! 24-hour HH:MM time, equivalent to %H:%M
441 687 : RESIZE_STRING(5_IK) ! fpp sets eposnew, and resizes string.
442 687 : write(string(epos + 1 : eposnew), "(I0.2,':',I0.2)") values(5:6)
443 : elseif (format(i:i) == SKC_"S") then ! Second (00-59)
444 692 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
445 692 : write(string(epos + 1 : eposnew), "(I0.2)") values(7)
446 : elseif (format(i:i) == SKC_"t") then ! Horizontal-tab character ('\t')
447 686 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
448 686 : string(epos + 1 : eposnew) = achar(9, SKC)
449 : elseif (format(i:i) == SKC_"T") then ! ISO 8601 time format (HH:MM:SS), equivalent to %H:%M:%S
450 695 : RESIZE_STRING(8_IK) ! fpp sets eposnew, and resizes string.
451 695 : write(string(epos + 1 : eposnew), "(I0.2,':',I0.2,':',I0.2)") values(5:7)
452 : elseif (format(i:i) == SKC_"u") then ! ISO 8601 weekday as number with Monday as 1 (1-7)
453 692 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
454 692 : write(string(epos + 1 : eposnew), "(I1)") getWeekDayISO(values(1), values(2), values(3))
455 : elseif (format(i:i) == SKC_"V") then ! ISO 8601 week number (01-53)
456 692 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
457 692 : write(string(epos + 1 : eposnew), "(I0.2)") getWeekNumber(values(1), values(2), values(3))
458 : elseif (format(i:i) == SKC_"w") then ! Weekday as a decimal number with Sunday as 0 (0-6)
459 689 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
460 689 : write(string(epos + 1 : eposnew), "(I1)") getWeekDay(values(1), values(2), values(3))
461 : elseif (format(i:i) == SKC_"x") then ! Date representation *
462 681 : RESIZE_STRING(8_IK) ! fpp sets eposnew, and resizes string.
463 681 : write(string(epos + 1 : eposnew), "(I0.2,'/',I0.2,'/',I0.2)") values(2), values(3), mod(abs(values(1)), 100_IKC) ! last two digits of year.
464 : elseif (format(i:i) == SKC_"X") then ! Time representation *
465 669 : RESIZE_STRING(8_IK) ! fpp sets eposnew, and resizes string.
466 669 : write(string(epos + 1 : eposnew), "(I0.2,':',I0.2,':',I0.2)") values(5:7)
467 : elseif (format(i:i) == SKC_"y") then ! Year, last two digits (00-99)
468 646 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
469 646 : write(string(epos + 1 : eposnew), "(I0.2)") mod(abs(values(1)), 100_IKC) ! last two digits of year.
470 : elseif (format(i:i) == SKC_"Y") then ! Year, last two digits (00-99)
471 656 : workspace9 = getStr(values(1))
472 656 : lenSeg = len_trim(workspace9, IKC)
473 656 : RESIZE_STRING(lenSeg) ! fpp sets eposnew, and resizes string.
474 656 : string(epos + 1 : eposnew) = workspace9(1:lenSeg)
475 : elseif (format(i:i) == SKC_"z") then ! ISO 8601 offset from UTC in timezone in units of minutes
476 648 : RESIZE_STRING(5_IK) ! fpp sets eposnew, and resizes string.
477 648 : write(string(epos + 1 : eposnew), "(sp,I0.4)") values(4)
478 : elseif (format(i:i) == SKC_"Z") then ! Timezone name or abbreviation.
479 611 : abbr = getZoneAbbr(values(4))
480 611 : RESIZE_STRING(len(abbr, IK))
481 611 : string(epos + 1 : eposnew) = abbr
482 : !if (values(4) == -60_IKC * 12_IKC) then ! International Day Line West time zone
483 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
484 : ! string(epos + 1 : eposnew) = SKC_"IDLW"
485 : !elseif (values(4) == -60_IKC * 11_IKC) then ! Samoa Standard Time
486 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
487 : ! string(epos + 1 : eposnew) = SKC_"SST"
488 : !elseif (values(4) == -60_IKC * 10_IKC) then ! Hawaii–Aleutian Standard Time
489 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
490 : ! string(epos + 1 : eposnew) = SKC_"HST"
491 : !elseif (values(4) == -60_IKC * 9_IKC - 30_IKC) then ! Marquesas Islands Time
492 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
493 : ! string(epos + 1 : eposnew) = SKC_"MIT"
494 : !elseif (values(4) == -60_IKC * 9_IKC) then ! Alaska Standard Time
495 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
496 : ! string(epos + 1 : eposnew) = SKC_"AKST"
497 : !elseif (values(4) == -60_IKC * 8_IKC) then ! Pacific Standard Time (North America)
498 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
499 : ! string(epos + 1 : eposnew) = SKC_"PST"
500 : !elseif (values(4) == -60_IKC * 7_IKC) then ! Mountain Standard Time (North America)
501 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
502 : ! string(epos + 1 : eposnew) = SKC_"MST"
503 : !elseif (values(4) == -60_IKC * 6_IKC) then ! Central Standard Time (North America)
504 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
505 : ! string(epos + 1 : eposnew) = SKC_"CST"
506 : !elseif (values(4) == -60_IKC * 5_IKC) then ! Eastern Standard Time (North America)
507 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
508 : ! string(epos + 1 : eposnew) = SKC_"EST"
509 : !elseif (values(4) == -60_IKC * 3_IKC - 30_IKC) then ! Newfoundland Standard Time
510 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
511 : ! string(epos + 1 : eposnew) = SKC_"NST"
512 : !elseif (values(4) == -60_IKC * 3_IKC) then ! Uruguay Standard Time
513 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
514 : ! string(epos + 1 : eposnew) = SKC_"UYT"
515 : !elseif (values(4) == -60_IKC * 2_IKC - 30_IKC) then ! Newfoundland Daylight Time
516 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
517 : ! string(epos + 1 : eposnew) = SKC_"NDT"
518 : !elseif (values(4) == -60_IKC * 2_IKC) then ! Uruguay Summer Time
519 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
520 : ! string(epos + 1 : eposnew) = SKC_"UYST"
521 : !elseif (values(4) == -60_IKC * 1_IKC) then ! Eastern Greenland Time
522 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
523 : ! string(epos + 1 : eposnew) = SKC_"EGT"
524 : !elseif (values(4) == 0_IKC) then ! Coordinated Universal Time
525 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
526 : ! string(epos + 1 : eposnew) = SKC_"UTC"
527 : !elseif (values(4) == +60_IKC * 1_IKC) then ! Central European Time
528 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
529 : ! string(epos + 1 : eposnew) = SKC_"CET"
530 : !elseif (values(4) == +60_IKC * 2_IKC) then ! Eastern European Time
531 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
532 : ! string(epos + 1 : eposnew) = SKC_"EET"
533 : !elseif (values(4) == +60_IKC * 3_IKC) then ! Arabia Standard Time
534 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
535 : ! string(epos + 1 : eposnew) = SKC_"AST"
536 : !elseif (values(4) == +60_IKC * 3_IKC + 30_IKC) then ! Iran Standard Time
537 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
538 : ! string(epos + 1 : eposnew) = SKC_"IRST"
539 : !elseif (values(4) == +60_IKC * 4_IKC) then ! Georgia Standard Time
540 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
541 : ! string(epos + 1 : eposnew) = SKC_"GET"
542 : !elseif (values(4) == +60_IKC * 4_IKC + 30_IKC) then ! Afghanistan Time
543 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
544 : ! string(epos + 1 : eposnew) = SKC_"AFT"
545 : !elseif (values(4) == +60_IKC * 5_IKC) then ! Pakistan Standard Time
546 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
547 : ! string(epos + 1 : eposnew) = SKC_"PKT"
548 : !elseif (values(4) == +60_IKC * 5_IKC + 30_IKC) then ! Indian Standard Time
549 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
550 : ! string(epos + 1 : eposnew) = SKC_"IST"
551 : !elseif (values(4) == +60_IKC * 5_IKC + 45_IKC) then ! Nepal Time
552 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
553 : ! string(epos + 1 : eposnew) = SKC_"NPT"
554 : !elseif (values(4) == +60_IKC * 6_IKC) then ! Bangladesh Standard Time
555 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
556 : ! string(epos + 1 : eposnew) = SKC_"BST"
557 : !elseif (values(4) == +60_IKC * 6_IKC + 30_IKC) then ! Myanmar Standard Time
558 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
559 : ! string(epos + 1 : eposnew) = SKC_"MMT"
560 : !elseif (values(4) == +60_IKC * 7_IKC) then ! Thailand Standard Time
561 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
562 : ! string(epos + 1 : eposnew) = SKC_"THA"
563 : !elseif (values(4) == +60_IKC * 8_IKC) then ! Singapore Standard Time
564 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
565 : ! string(epos + 1 : eposnew) = SKC_"SST"
566 : !elseif (values(4) == +60_IKC * 8_IKC + 45_IKC) then ! Central Western Standard Time (Australia)
567 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
568 : ! string(epos + 1 : eposnew) = SKC_"CWST"
569 : !elseif (values(4) == +60_IKC * 9_IKC) then ! Japan Standard Time
570 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
571 : ! string(epos + 1 : eposnew) = SKC_"JST"
572 : !elseif (values(4) == +60_IKC * 9_IKC + 30_IKC) then ! Australian Central Standard Time
573 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
574 : ! string(epos + 1 : eposnew) = SKC_"ACST"
575 : !elseif (values(4) == +60_IKC * 10_IKC) then ! Australian Eastern Standard Time
576 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
577 : ! string(epos + 1 : eposnew) = SKC_"AEST"
578 : !elseif (values(4) == +60_IKC * 10_IKC + 30_IKC) then ! Lord Howe Standard Time
579 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
580 : ! string(epos + 1 : eposnew) = SKC_"LHST"
581 : !elseif (values(4) == +60_IKC * 11_IKC) then ! Pohnpei Standard Time
582 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
583 : ! string(epos + 1 : eposnew) = SKC_"PONT"
584 : !elseif (values(4) == +60_IKC * 12_IKC) then ! New Zealand Standard Time
585 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
586 : ! string(epos + 1 : eposnew) = SKC_"NZST"
587 : !elseif (values(4) == +60_IKC * 12_IKC + 45_IKC) then ! Chatham Standard Time
588 : ! RESIZE_STRING(5_IK) ! fpp sets eposnew, and resizes string.
589 : ! string(epos + 1 : eposnew) = SKC_"CHAST"
590 : !elseif (values(4) == +60_IKC * 13_IKC) then ! Tonga Time
591 : ! RESIZE_STRING(3_IK) ! fpp sets eposnew, and resizes string.
592 : ! string(epos + 1 : eposnew) = SKC_"TOT"
593 : !elseif (values(4) == +60_IKC * 13_IKC + 45_IKC) then ! Chatham Daylight Time
594 : ! RESIZE_STRING(5_IK) ! fpp sets eposnew, and resizes string.
595 : ! string(epos + 1 : eposnew) = SKC_"CHADT"
596 : !elseif (values(4) == +60_IKC * 14_IKC) then ! Line Islands Time
597 : ! RESIZE_STRING(4_IK) ! fpp sets eposnew, and resizes string.
598 : ! string(epos + 1 : eposnew) = SKC_"LINT"
599 : !end if
600 : elseif (format(i:i) == SKC_"%") then ! add percentage.
601 556 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
602 556 : string(epos + 1 : eposnew) = SKC_"%"
603 : else ! Unrecognized format.
604 1380 : RESIZE_STRING(2_IK) ! fpp sets eposnew, and resizes string.
605 1380 : string(epos + 1 : eposnew) = format(i - 1 : i)
606 : end if
607 : else ! normal characters.
608 11980 : RESIZE_STRING(1_IK) ! fpp sets eposnew, and resizes string.
609 11980 : string(epos + 1 : eposnew) = format(i : i)
610 : end if
611 : end do
612 20138 : if (lenString > eposnew) then
613 20089 : tempstr = string(1:eposnew)
614 20089 : call move_alloc(tempstr, string)
615 : end if
616 : #else
617 : #error "Unrecognized interface."
618 : #endif
619 :
620 : #undef RESIZE_STRING
621 :
622 : !%%%%%%%%%%%%%%%%%%%%%%%%%
623 : #elif getDateTimeNewZone_ENABLED
624 : !%%%%%%%%%%%%%%%%%%%%%%%%%
625 :
626 : ! The case for no input (current) date and time.
627 : #if getDateTimeNewZoneC_ENABLED
628 : integer(IKC) :: values(8)
629 5588 : call date_and_time(values = values)
630 50292 : CHECK_ASSERTION(__LINE__, all(values /= -huge(0_IKC)), SK_"@getDateTimeNewZone(): The processor does not have a clock.") ! fpp
631 5588 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
632 : ! The case for vector of date and time.
633 : #elif getDateTimeNewZoneV_ENABLED
634 : integer(IK) :: lenValues
635 27012 : lenValues = size(values, 1, IK)
636 27012 : CHECK_ASSERTION(__LINE__, 3_IK < lenValues .and. lenValues < 9_IK, SK_"@getDateTimeNewZone(): The condition `3 < size(values) < 9` must hold. size(values) = "//getStr(size(values))) ! fpp
637 27012 : if (lenValues == 8_IK) then
638 7006 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
639 20006 : elseif (lenValues == 7_IK) then
640 5001 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4), values(5), values(6), values(7))
641 15005 : elseif (lenValues == 6_IK) then
642 5002 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4), values(5), values(6))
643 10003 : elseif (lenValues == 5_IK) then
644 5003 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4), values(5))
645 5000 : elseif (lenValues == 4_IK) then
646 5000 : DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3), values(4))
647 : !elseif (lenValues == 3_IK) then
648 : ! DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2), values(3))
649 : !elseif (lenValues == 2_IK) then
650 : ! DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1), values(2))
651 : !elseif (lenValues == 1_IK) then
652 : ! DateTimeNewZone(1:8) = getDateTimeNewZone(newzone, values(1))
653 : else
654 : error stop MODULE_NAME//SK_"@getDateTimeNewZone(): The length of the input argument `values` must be less than 9 and larger than 3. size(values) = "//getStr(lenValues) ! LCOV_EXCL_LINE
655 : end if
656 : ! The case for keyword date and time.
657 : #else
658 : #if !getDateTimeNewZoneYMDZHMSM_ENABLED
659 : integer(IKC), parameter :: millisecond = 0_IK
660 : #if !getDateTimeNewZoneYMDZHMS_ENABLED
661 : integer(IKC), parameter :: second = 0_IK
662 : #if !getDateTimeNewZoneYMDZHM_ENABLED
663 : integer(IKC), parameter :: minute = 0_IK
664 : #if !getDateTimeNewZoneYMDZH_ENABLED
665 : integer(IKC), parameter :: hour = 0_IK
666 : #if !getDateTimeNewZoneYMDZ_ENABLED
667 : #error "Unrecognized interface."
668 : #endif
669 : #endif
670 : #endif
671 : #endif
672 : #endif
673 57615 : if (zone /= 0_IK .and. newzone /= 0_IK .and. zone /= newzone) then
674 55514 : DateTimeNewZone(1:8) = getDateTimeUTC(year, month, day, zone, hour, minute, second, millisecond)
675 499626 : DateTimeNewZone(1:8) = getDateTimeUTC(DateTimeNewZone(1), DateTimeNewZone(2), DateTimeNewZone(3), -newzone, DateTimeNewZone(5), DateTimeNewZone(6), DateTimeNewZone(7), DateTimeNewZone(8))
676 55514 : DateTimeNewZone(4) = newzone
677 2101 : elseif (zone /= 0_IK .and. newzone == 0_IK) then
678 24 : DateTimeNewZone(1:8) = getDateTimeUTC(year, month, day, zone, hour, minute, second, millisecond)
679 2077 : elseif (zone == 0_IK .and. newzone /= 0_IK) then
680 2010 : DateTimeNewZone(1:8) = getDateTimeUTC(year, month, day, -newzone, hour, minute, second, millisecond)
681 2010 : DateTimeNewZone(4) = newzone
682 : else
683 67 : DateTimeNewZone(1) = year
684 67 : DateTimeNewZone(2) = month
685 67 : DateTimeNewZone(3) = day
686 67 : DateTimeNewZone(4) = zone
687 67 : DateTimeNewZone(5) = hour
688 67 : DateTimeNewZone(6) = minute
689 67 : DateTimeNewZone(7) = second
690 67 : DateTimeNewZone(8) = millisecond
691 : end if
692 : #endif
693 :
694 : !%%%%%%%%%%%%%%%%%%%%%
695 : #elif getDateTimeUTC_ENABLED
696 : !%%%%%%%%%%%%%%%%%%%%%
697 :
698 : ! The case for no input (current) date and time.
699 : #if getDateTimeUTCC_ENABLED
700 : integer(IKC) :: values(8)
701 5 : call date_and_time(values = values)
702 45 : CHECK_ASSERTION(__LINE__, all(values /= -huge(0_IKC)), SK_"@getDateTimeUTC(): The processor does not have a clock.") ! fpp
703 5 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
704 : ! The case for vector of date and time.
705 : #elif getDateTimeUTCV_ENABLED
706 : integer(IK) :: lenValues
707 25000 : lenValues = size(values, 1, IK)
708 25000 : CHECK_ASSERTION(__LINE__, 3_IK < lenValues .and. lenValues < 9_IK, SK_"@getDateTimeUTC(): The condition `3 < size(values) < 9` must hold. size(values) = "//getStr(size(values))) ! fpp
709 25000 : if (lenValues == 8_IK) then
710 5000 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
711 20000 : elseif (lenValues == 7_IK) then
712 5000 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4), values(5), values(6), values(7))
713 15000 : elseif (lenValues == 6_IK) then
714 5000 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4), values(5), values(6))
715 10000 : elseif (lenValues == 5_IK) then
716 5000 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4), values(5))
717 5000 : elseif (lenValues == 4_IK) then
718 5000 : DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3), values(4))
719 : !elseif (lenValues == 3_IK) then
720 : ! DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2), values(3))
721 : !elseif (lenValues == 2_IK) then
722 : ! DateTimeUTC(1:8) = getDateTimeUTC(values(1), values(2))
723 : !elseif (lenValues == 1_IK) then
724 : ! DateTimeUTC(1:8) = getDateTimeUTC(values(1))
725 : else
726 : error stop MODULE_NAME//SK_"@getDateTimeUTC(): The length of the input argument `values` must be less than 9 and larger than 3. size(values) = "//getStr(lenValues) ! LCOV_EXCL_LINE
727 : end if
728 : ! The case for keyword date and time.
729 : #else
730 : #if !getDateTimeUTCYMDZHMSM_ENABLED
731 : integer(IKC), parameter :: millisecond = 0_IK
732 : #if !getDateTimeUTCYMDZHMS_ENABLED
733 : integer(IKC), parameter :: second = 0_IK
734 : #if !getDateTimeUTCYMDZHM_ENABLED
735 : integer(IKC), parameter :: minute = 0_IK
736 : #if !getDateTimeUTCYMDZH_ENABLED
737 : integer(IKC), parameter :: hour = 0_IK
738 : #if !getDateTimeUTCYMDZ_ENABLED
739 : #error "Unrecognized interface."
740 : #endif
741 : #endif
742 : #endif
743 : #endif
744 : #endif
745 : integer(IKC) :: offsetDays
746 : integer(IKC) :: totalHours
747 : integer(IKC) :: offsetHours
748 : integer(IKC) :: totalMinutes
749 282961 : DateTimeUTC(8) = millisecond
750 282961 : DateTimeUTC(7) = second
751 282961 : if (zone /= 0_IKC) then
752 282911 : totalMinutes = minute - zone
753 282911 : offsetHours = totalMinutes / 60_IKC
754 282911 : DateTimeUTC(6) = totalMinutes - offsetHours * 60_IKC
755 282911 : if (DateTimeUTC(6) < 0_IKC) then
756 79431 : DateTimeUTC(6) = DateTimeUTC(6) + 60_IKC
757 79431 : offsetHours = offsetHours - 1_IKC
758 : end if
759 272919 : totalHours = hour + offsetHours
760 282911 : offsetDays = totalHours / 24_IKC
761 282911 : DateTimeUTC(5) = totalHours - offsetDays * 24_IKC
762 282911 : if (DateTimeUTC(5) < 0_IKC) then
763 20182 : DateTimeUTC(5) = DateTimeUTC(5) + 24_IKC
764 20182 : offsetDays = offsetDays - 1_IKC
765 : end if
766 282911 : DateTimeUTC(4) = 0_IKC ! UTC zone
767 282911 : CHECK_ASSERTION(__LINE__, offsetDays > -2_IKC .and. offsetDays < 2_IKC, SK_"@getDateTimeUTC(): Internal library error: The condition `offsetDays > -2_IKC .and. offsetDays < 2_IKC` must hold. Please report this error to the ParaMonte library developers.")
768 282911 : if (offsetDays == -1_IKC) then
769 20182 : DateTimeUTC(1:3) = getDateBefore(year, month, day)
770 262729 : elseif (offsetDays == +1_IKC) then
771 41799 : DateTimeUTC(1:3) = getDateAfter(year, month, day)
772 : else
773 220930 : DateTimeUTC(3) = day
774 220930 : DateTimeUTC(2) = month
775 220930 : DateTimeUTC(1) = year
776 : end if
777 : else
778 50 : DateTimeUTC(1) = year
779 50 : DateTimeUTC(2) = month
780 50 : DateTimeUTC(3) = day
781 50 : DateTimeUTC(4) = zone
782 50 : DateTimeUTC(5) = hour
783 50 : DateTimeUTC(6) = minute
784 50 : DateTimeUTC(7) = second
785 50 : DateTimeUTC(8) = millisecond
786 : end if
787 : #endif
788 :
789 : !%%%%%%%%%%%%%%%%%%%%%%%%%
790 : #elif getDateTimeShifted_ENABLED
791 : !%%%%%%%%%%%%%%%%%%%%%%%%%
792 :
793 : ! The case for no input (current) date and time.
794 : #if getDateTimeShiftedC_ENABLED
795 : integer(IKC) :: values(8)
796 3 : call date_and_time(values = values)
797 27 : CHECK_ASSERTION(__LINE__, all(values /= -huge(0_IKC)), SK_"@getDateTimeShifted(): The processor does not have a clock.") ! fpp
798 3 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
799 : ! The case for vector of date and time.
800 : #elif getDateTimeShiftedV_ENABLED
801 : integer(IK) :: lenValues
802 55041 : lenValues = size(values, 1, IK)
803 55041 : CHECK_ASSERTION(__LINE__, 0_IK < lenValues .and. lenValues < 9_IK, SK_"@getDateTimeShifted(): The condition `0 < size(values) < 9` must hold. size(values) = "//getStr(size(values))) ! fpp
804 55041 : if (lenValues == 8_IK) then
805 15018 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
806 : elseif (lenValues == 7_IK) then
807 10005 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4), values(5), values(6), values(7))
808 : elseif (lenValues == 6_IK) then
809 10005 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4), values(5), values(6))
810 : elseif (lenValues == 5_IK) then
811 10005 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4), values(5))
812 : elseif (lenValues == 4_IK) then
813 10004 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3), values(4))
814 : elseif (lenValues == 3_IK) then
815 2 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2), values(3))
816 : elseif (lenValues == 2_IK) then
817 1 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1), values(2))
818 : elseif (lenValues == 1_IK) then
819 1 : dateTimeShifted(1:8) = getDateTimeShifted(amount, values(1))
820 : else
821 : error stop MODULE_NAME//SK_"@getDateTimeShifted(): The length of the input argument `values` must be less than 9 and non-zero. size(values) = "//getStr(lenValues) ! LCOV_EXCL_LINE
822 : end if
823 : ! The case for keyword date and time.
824 : #else
825 : #if !getDateTimeShiftedYMDZHMSM_ENABLED
826 : integer(IKC), parameter :: millisecond = 0_IK
827 : #if !getDateTimeShiftedYMDZHMS_ENABLED
828 : integer(IKC), parameter :: second = 0_IK
829 : #if !getDateTimeShiftedYMDZHM_ENABLED
830 : integer(IKC), parameter :: minute = 0_IK
831 : #if !getDateTimeShiftedYMDZH_ENABLED
832 : integer(IKC), parameter :: hour = 0_IK
833 : #if !getDateTimeShiftedYMDZ_ENABLED
834 : integer(IKC), parameter :: zone = 0_IK
835 : #if !getDateTimeShiftedYMD_ENABLED
836 : integer(IKC), parameter :: day = 1_IK
837 : #if !getDateTimeShiftedYM_ENABLED
838 : integer(IKC), parameter :: month = 1_IK
839 : #if !getDateTimeShiftedY_ENABLED
840 : #error "Unrecognized interface."
841 : #endif
842 : #endif
843 : #endif
844 : #endif
845 : #endif
846 : #endif
847 : #endif
848 : #endif
849 : real(RKC) :: julianDay
850 495954 : CHECK_ASSERTION(__LINE__, isValidDateTime(year, month, day, zone, hour, minute, second, millisecond), \
851 : SK_"@getDateTimeShifted(): The specified Gregorian date and time must be valid and consistent. [year, month, day, zone, hour, minute, second, millisecond] = "// \
852 : getStr([year, month, day, zone, hour, minute, second, millisecond])) ! fpp
853 55106 : julianDay = getJulianDay(year, month, day, 0_IK, hour, minute, second, millisecond)
854 : !dateTimeShifted(1:8) = getDateTime(julianDay + amount, zone)
855 55106 : dateTimeShifted(1:8) = getDateTime(julianDay + amount)
856 55106 : dateTimeShifted(4) = zone
857 : #endif
858 :
859 : !%%%%%%%%%%%%%%%%%%%
860 : #elif getJulianDay_ENABLED
861 : !%%%%%%%%%%%%%%%%%%%
862 :
863 : ! The case for no input (current) date and time.
864 : #if getJulianDayC_ENABLED
865 : integer(IKC) :: values(8)
866 3 : call date_and_time(values = values)
867 27 : CHECK_ASSERTION(__LINE__, all(values /= -huge(0_IKC)), SK_"@getJulianDay(): The processor does not have a clock.") ! fpp
868 3 : julianDay = getJulianDay(values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
869 : ! The case for vector of date and time.
870 : #elif getJulianDayV_ENABLED
871 : integer(IK) :: lenValues
872 119934 : lenValues = size(values, 1, IK)
873 119934 : CHECK_ASSERTION(__LINE__, 0_IK < lenValues .and. lenValues < 9_IK, SK_"@getJulianDay(): The condition `0 < size(values) < 9` must hold. size(values) = "//getStr(size(values))) ! fpp
874 119934 : if (lenValues == 8_IK) then
875 119865 : julianDay = getJulianDay(values(1), values(2), values(3), values(4), values(5), values(6), values(7), values(8))
876 : elseif (lenValues == 7_IK) then
877 14 : julianDay = getJulianDay(values(1), values(2), values(3), values(4), values(5), values(6), values(7))
878 : elseif (lenValues == 6_IK) then
879 14 : julianDay = getJulianDay(values(1), values(2), values(3), values(4), values(5), values(6))
880 : elseif (lenValues == 5_IK) then
881 14 : julianDay = getJulianDay(values(1), values(2), values(3), values(4), values(5))
882 : elseif (lenValues == 4_IK) then
883 9 : julianDay = getJulianDay(values(1), values(2), values(3), values(4))
884 : elseif (lenValues == 3_IK) then
885 9 : julianDay = getJulianDay(values(1), values(2), values(3))
886 : elseif (lenValues == 2_IK) then
887 5 : julianDay = getJulianDay(values(1), values(2))
888 : elseif (lenValues == 1_IK) then
889 4 : julianDay = getJulianDay(values(1))
890 : else
891 : error stop MODULE_NAME//SK_"@getJulianDay(): The length of the input argument `values` must be less than 9 and non-zero. size(values) = "//getStr(lenValues) ! LCOV_EXCL_LINE
892 : end if
893 : ! The case for keyword date and time.
894 : #else
895 : #if !getJulianDayYMDZHMSM_ENABLED
896 : integer(IKC), parameter :: millisecond = 0_IK
897 : #if !getJulianDayYMDZHMS_ENABLED
898 : integer(IKC), parameter :: second = 0_IK
899 : #if !getJulianDayYMDZHM_ENABLED
900 : integer(IKC), parameter :: minute = 0_IK
901 : #if !getJulianDayYMDZH_ENABLED
902 : integer(IKC), parameter :: hour = 0_IK
903 : #if !getJulianDayYMDZ_ENABLED
904 : integer(IKC), parameter :: zone = 0_IK
905 : #if !getJulianDayYMD_ENABLED
906 : integer(IKC), parameter :: day = 1_IK
907 : #if !getJulianDayYM_ENABLED
908 : integer(IKC), parameter :: month = 1_IK
909 : #if !getJulianDayY_ENABLED
910 : #error "Unrecognized interface."
911 : #endif
912 : #endif
913 : #endif
914 : #endif
915 : #endif
916 : #endif
917 : #endif
918 : #endif
919 : real(RKC) , parameter :: DAY_PER_HOUR = 1._RKC / 24._RKC
920 : real(RKC) , parameter :: DAY_PER_MIN = 1._RKC / 1440._RKC
921 : real(RKC) , parameter :: DAY_PER_SEC = 1._RKC / 86400._RKC
922 : integer(IKC), parameter :: VECTOR(12) = [306_IKC, 337_IKC, 0_IKC, 31_IKC, 61_IKC, 92_IKC, 122_IKC, 153_IKC, 184_IKC, 214_IKC, 245_IKC, 275_IKC]
923 : integer(IKC) :: yearCorrected, DateTimeUTC(8)
924 :
925 2029086 : CHECK_ASSERTION(__LINE__, isValidDateTime(year, month, day, zone, hour, minute, second, millisecond), \
926 : SK_"@getJulianDay(): The specified Gregorian date and time must be valid and consistent. [year, month, day, zone, hour, minute, second, millisecond] = "// \
927 : getStr([year, month, day, zone, hour, minute, second, millisecond])) ! fpp
928 :
929 205120 : if (zone /= 0_IK) then
930 119884 : DateTimeUTC(1:8) = getDateTimeUTC(year, month, day, zone, hour, minute, second, millisecond)
931 : else
932 105570 : DateTimeUTC(1) = year
933 105570 : DateTimeUTC(2) = month
934 105570 : DateTimeUTC(3) = day
935 105570 : DateTimeUTC(4) = zone
936 105570 : DateTimeUTC(5) = hour
937 105570 : DateTimeUTC(6) = minute
938 105570 : DateTimeUTC(7) = second
939 85236 : DateTimeUTC(8) = millisecond
940 : end if
941 :
942 225445 : if (DateTimeUTC(2) == 1_IKC .or. DateTimeUTC(2) == 2_IKC) then
943 14278 : yearCorrected = DateTimeUTC(1) - 1_IKC
944 : else
945 192637 : yearCorrected = DateTimeUTC(1)
946 : end if
947 : julianDay = 1721118.5_RKC & ! LCOV_EXCL_LINE
948 : + real(DateTimeUTC(3), RKC) & ! LCOV_EXCL_LINE
949 : + real(VECTOR(DateTimeUTC(2)), RKC) & ! LCOV_EXCL_LINE
950 : + 365._RKC * real(yearCorrected, RKC) & ! LCOV_EXCL_LINE
951 : + real(floor(yearCorrected * 0.25_RKC, IKC) - floor(yearCorrected * 0.01_RKC, IKC) + floor(yearCorrected * 0.0025_RKC, IKC), RKC) & ! LCOV_EXCL_LINE
952 225454 : + DateTimeUTC(5) * DAY_PER_HOUR + DateTimeUTC(6) * DAY_PER_MIN + (real(DateTimeUTC(7),RKC) + 0.001_RKC * DateTimeUTC(8)) * DAY_PER_SEC
953 : #endif
954 :
955 : !%%%%%%%%%%%%%%%%%%%%%%
956 : #else
957 : #error "Unrecognized interface."
958 : #endif
959 : !%%%%%%%%%%%%%%%%%%%%%%
|
