1 | MODULE calendar |
---|
2 | !- |
---|
3 | !$Id$ |
---|
4 | !- |
---|
5 | ! This software is governed by the CeCILL license |
---|
6 | ! See IOIPSL/IOIPSL_License_CeCILL.txt |
---|
7 | !--------------------------------------------------------------------- |
---|
8 | !- This is the calendar which going to be used to do all |
---|
9 | !- calculations on time. Three types of calendars are possible : |
---|
10 | !- |
---|
11 | !- - gregorian : |
---|
12 | !- The normal calendar. The time origin for the |
---|
13 | !- julian day in this case is 24 Nov -4713 |
---|
14 | !- (other names : 'standard','proleptic_gregorian') |
---|
15 | !- - noleap : |
---|
16 | !- A 365 day year without leap years. |
---|
17 | !- The origin for the julian days is in this case 1 Jan 0 |
---|
18 | !- (other names : '365_day','365d') |
---|
19 | !- - all_leap : |
---|
20 | !- A 366 day year with leap years. |
---|
21 | !- The origin for the julian days is in this case ???? |
---|
22 | !- (other names : '366_day','366d' |
---|
23 | !- - julian : |
---|
24 | !- same as gregorian, but with all leap century years |
---|
25 | !- - xxxd : |
---|
26 | !- Year of xxx days with month of equal length. |
---|
27 | !- The origin for the julian days is then also 1 Jan 0 |
---|
28 | !- |
---|
29 | !- As one can see it is difficult to go from one calendar to the other. |
---|
30 | !- All operations involving julian days will be wrong. |
---|
31 | !- This calendar will lock as soon as possible |
---|
32 | !- the length of the year and forbid any further modification. |
---|
33 | !- |
---|
34 | !- For the non leap-year calendar the method is still brute force. |
---|
35 | !- We need to find an Integer series which takes care of the length |
---|
36 | !- of the various month. (Jan) |
---|
37 | !- |
---|
38 | !- one_day : one day in seconds |
---|
39 | !- one_year : one year in days |
---|
40 | !--------------------------------------------------------------------- |
---|
41 | USE stringop,ONLY : strlowercase |
---|
42 | USE errioipsl,ONLY : ipslerr |
---|
43 | !- |
---|
44 | PRIVATE |
---|
45 | PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, & |
---|
46 | & ioget_calendar,ioget_mon_len,ioget_year_len,itau2date, & |
---|
47 | & ioget_timestamp,ioconf_startdate,itau2ymds, & |
---|
48 | & time_diff,time_add,lock_calendar |
---|
49 | !- |
---|
50 | INTERFACE ioget_calendar |
---|
51 | MODULE PROCEDURE & |
---|
52 | & ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str |
---|
53 | END INTERFACE |
---|
54 | !- |
---|
55 | INTERFACE ioconf_startdate |
---|
56 | MODULE PROCEDURE & |
---|
57 | & ioconf_startdate_simple,ioconf_startdate_internal, & |
---|
58 | & ioconf_startdate_ymds |
---|
59 | END INTERFACE |
---|
60 | !- |
---|
61 | REAL,PARAMETER :: one_day = 86400.0 |
---|
62 | LOGICAL,SAVE :: lock_startdate = .FALSE. |
---|
63 | !- |
---|
64 | CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX' |
---|
65 | !- |
---|
66 | !- Description of calendar |
---|
67 | !- |
---|
68 | CHARACTER(LEN=20),SAVE :: calendar_used="gregorian" |
---|
69 | LOGICAL,SAVE :: lock_one_year = .FALSE. |
---|
70 | REAL,SAVE :: one_year = 365.2425 |
---|
71 | INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/) |
---|
72 | !- |
---|
73 | CHARACTER(LEN=3),PARAMETER :: & |
---|
74 | & cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', & |
---|
75 | & 'JUL','AUG','SEP','OCT','NOV','DEC'/) |
---|
76 | !- |
---|
77 | REAL,SAVE :: start_day,start_sec |
---|
78 | !- |
---|
79 | CONTAINS |
---|
80 | !- |
---|
81 | !=== |
---|
82 | !- |
---|
83 | SUBROUTINE lock_calendar (new_status,old_status) |
---|
84 | !!-------------------------------------------------------------------- |
---|
85 | !! The "lock_calendar" routine |
---|
86 | !! allows to lock or unlock the calendar, |
---|
87 | !! and to know the current status of the calendar. |
---|
88 | !! Be careful ! |
---|
89 | !! |
---|
90 | !! SUBROUTINE lock_calendar (new_status,old_status) |
---|
91 | !! |
---|
92 | !! Optional INPUT argument |
---|
93 | !! |
---|
94 | !! (L) new_status : new status of the calendar |
---|
95 | !! |
---|
96 | !! Optional OUTPUT argument |
---|
97 | !! |
---|
98 | !! (L) old_status : current status of the calendar |
---|
99 | !!-------------------------------------------------------------------- |
---|
100 | IMPLICIT NONE |
---|
101 | !- |
---|
102 | LOGICAL,OPTIONAL,INTENT(IN) :: new_status |
---|
103 | LOGICAL,OPTIONAL,INTENT(OUT) :: old_status |
---|
104 | !--------------------------------------------------------------------- |
---|
105 | IF (PRESENT(old_status)) THEN |
---|
106 | old_status = lock_one_year |
---|
107 | ENDIF |
---|
108 | IF (PRESENT(new_status)) THEN |
---|
109 | lock_one_year = new_status |
---|
110 | ENDIF |
---|
111 | !--------------------------- |
---|
112 | END SUBROUTINE lock_calendar |
---|
113 | !- |
---|
114 | !=== |
---|
115 | !- |
---|
116 | SUBROUTINE ymds2ju (year,month,day,sec,julian) |
---|
117 | !--------------------------------------------------------------------- |
---|
118 | IMPLICIT NONE |
---|
119 | !- |
---|
120 | INTEGER,INTENT(IN) :: year,month,day |
---|
121 | REAL,INTENT(IN) :: sec |
---|
122 | !- |
---|
123 | REAL,INTENT(OUT) :: julian |
---|
124 | !- |
---|
125 | INTEGER :: julian_day |
---|
126 | REAL :: julian_sec |
---|
127 | !--------------------------------------------------------------------- |
---|
128 | CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) |
---|
129 | !- |
---|
130 | julian = julian_day+julian_sec/one_day |
---|
131 | !--------------------- |
---|
132 | END SUBROUTINE ymds2ju |
---|
133 | !- |
---|
134 | !=== |
---|
135 | !- |
---|
136 | SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) |
---|
137 | !--------------------------------------------------------------------- |
---|
138 | !- Converts year, month, day and seconds into a julian day |
---|
139 | !- |
---|
140 | !- In 1968 in a letter to the editor of Communications of the ACM |
---|
141 | !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel |
---|
142 | !- and Thomas C. Van Flandern presented such an algorithm. |
---|
143 | !- |
---|
144 | !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm |
---|
145 | !- |
---|
146 | !- In the case of the Gregorian calendar we have chosen to use |
---|
147 | !- the Lilian day numbers. This is the day counter which starts |
---|
148 | !- on the 15th October 1582. |
---|
149 | !- This is the day at which Pope Gregory XIII introduced the |
---|
150 | !- Gregorian calendar. |
---|
151 | !- Compared to the true Julian calendar, which starts some |
---|
152 | !- 7980 years ago, the Lilian days are smaler and are dealt with |
---|
153 | !- easily on 32 bit machines. With the true Julian days you can only |
---|
154 | !- the fraction of the day in the real part to a precision of |
---|
155 | !- a 1/4 of a day with 32 bits. |
---|
156 | !--------------------------------------------------------------------- |
---|
157 | IMPLICIT NONE |
---|
158 | !- |
---|
159 | INTEGER,INTENT(IN) :: year,month,day |
---|
160 | REAL,INTENT(IN) :: sec |
---|
161 | !- |
---|
162 | INTEGER,INTENT(OUT) :: julian_day |
---|
163 | REAL,INTENT(OUT) :: julian_sec |
---|
164 | !- |
---|
165 | INTEGER :: jd,m,y,d,ml |
---|
166 | !--------------------------------------------------------------------- |
---|
167 | lock_one_year = .TRUE. |
---|
168 | !- |
---|
169 | m = month |
---|
170 | y = year |
---|
171 | d = day |
---|
172 | !- |
---|
173 | !- We deduce the calendar from the length of the year as it |
---|
174 | !- is faster than an INDEX on the calendar variable. |
---|
175 | !- |
---|
176 | IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN |
---|
177 | !-- "Gregorian" |
---|
178 | jd = (1461*(y+4800+INT((m-14)/12)))/4 & |
---|
179 | & +(367*(m-2-12*(INT((m-14)/12))))/12 & |
---|
180 | & -(3*((y+4900+INT((m-14)/12))/100))/4 & |
---|
181 | & +d-32075 |
---|
182 | jd = jd-2299160 |
---|
183 | ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & |
---|
184 | & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN |
---|
185 | !-- "No leap" or "All leap" |
---|
186 | ml = SUM(mon_len(1:m-1)) |
---|
187 | jd = y*NINT(one_year)+ml+(d-1) |
---|
188 | ELSE |
---|
189 | !-- Calendar with regular month |
---|
190 | ml = NINT(one_year/12.) |
---|
191 | jd = y*NINT(one_year)+(m-1)*ml+(d-1) |
---|
192 | ENDIF |
---|
193 | !- |
---|
194 | julian_day = jd |
---|
195 | julian_sec = sec |
---|
196 | !------------------------------ |
---|
197 | END SUBROUTINE ymds2ju_internal |
---|
198 | !- |
---|
199 | !=== |
---|
200 | !- |
---|
201 | SUBROUTINE ju2ymds (julian,year,month,day,sec) |
---|
202 | !--------------------------------------------------------------------- |
---|
203 | IMPLICIT NONE |
---|
204 | !- |
---|
205 | REAL,INTENT(IN) :: julian |
---|
206 | !- |
---|
207 | INTEGER,INTENT(OUT) :: year,month,day |
---|
208 | REAL,INTENT(OUT) :: sec |
---|
209 | !- |
---|
210 | INTEGER :: julian_day |
---|
211 | REAL :: julian_sec |
---|
212 | !--------------------------------------------------------------------- |
---|
213 | julian_day = INT(julian) |
---|
214 | julian_sec = (julian-julian_day)*one_day |
---|
215 | !- |
---|
216 | CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec) |
---|
217 | !--------------------- |
---|
218 | END SUBROUTINE ju2ymds |
---|
219 | !- |
---|
220 | !=== |
---|
221 | !- |
---|
222 | SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) |
---|
223 | !--------------------------------------------------------------------- |
---|
224 | !- This subroutine computes from the julian day the year, |
---|
225 | !- month, day and seconds |
---|
226 | !- |
---|
227 | !- In 1968 in a letter to the editor of Communications of the ACM |
---|
228 | !- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel |
---|
229 | !- and Thomas C. Van Flandern presented such an algorithm. |
---|
230 | !- |
---|
231 | !- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm |
---|
232 | !- |
---|
233 | !- In the case of the Gregorian calendar we have chosen to use |
---|
234 | !- the Lilian day numbers. This is the day counter which starts |
---|
235 | !- on the 15th October 1582. This is the day at which Pope |
---|
236 | !- Gregory XIII introduced the Gregorian calendar. |
---|
237 | !- Compared to the true Julian calendar, which starts some 7980 |
---|
238 | !- years ago, the Lilian days are smaler and are dealt with easily |
---|
239 | !- on 32 bit machines. With the true Julian days you can only the |
---|
240 | !- fraction of the day in the real part to a precision of a 1/4 of |
---|
241 | !- a day with 32 bits. |
---|
242 | !--------------------------------------------------------------------- |
---|
243 | IMPLICIT NONE |
---|
244 | !- |
---|
245 | INTEGER,INTENT(IN) :: julian_day |
---|
246 | REAL,INTENT(IN) :: julian_sec |
---|
247 | !- |
---|
248 | INTEGER,INTENT(OUT) :: year,month,day |
---|
249 | REAL,INTENT(OUT) :: sec |
---|
250 | !- |
---|
251 | INTEGER :: l,n,i,jd,j,d,m,y,ml |
---|
252 | INTEGER :: add_day |
---|
253 | REAL :: eps_day |
---|
254 | !--------------------------------------------------------------------- |
---|
255 | eps_day = SPACING(one_day) |
---|
256 | lock_one_year = .TRUE. |
---|
257 | !- |
---|
258 | jd = julian_day |
---|
259 | sec = julian_sec |
---|
260 | IF (sec > (one_day-eps_day)) THEN |
---|
261 | add_day = INT(sec/one_day) |
---|
262 | sec = sec-add_day*one_day |
---|
263 | jd = jd+add_day |
---|
264 | ENDIF |
---|
265 | IF (sec < -eps_day) THEN |
---|
266 | sec = sec+one_day |
---|
267 | jd = jd-1 |
---|
268 | ENDIF |
---|
269 | !- |
---|
270 | IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN |
---|
271 | !-- Gregorian |
---|
272 | jd = jd+2299160 |
---|
273 | !- |
---|
274 | l = jd+68569 |
---|
275 | n = (4*l)/146097 |
---|
276 | l = l-(146097*n+3)/4 |
---|
277 | i = (4000*(l+1))/1461001 |
---|
278 | l = l-(1461*i)/4+31 |
---|
279 | j = (80*l)/2447 |
---|
280 | d = l-(2447*j)/80 |
---|
281 | l = j/11 |
---|
282 | m = j+2-(12*l) |
---|
283 | y = 100*(n-49)+i+l |
---|
284 | ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & |
---|
285 | & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN |
---|
286 | !-- No leap or All leap |
---|
287 | y = jd/NINT(one_year) |
---|
288 | l = jd-y*NINT(one_year) |
---|
289 | m = 1 |
---|
290 | ml = 0 |
---|
291 | DO WHILE (ml+mon_len(m) <= l) |
---|
292 | ml = ml+mon_len(m) |
---|
293 | m = m+1 |
---|
294 | ENDDO |
---|
295 | d = l-ml+1 |
---|
296 | ELSE |
---|
297 | !-- others |
---|
298 | ml = NINT(one_year/12.) |
---|
299 | y = jd/NINT(one_year) |
---|
300 | l = jd-y*NINT(one_year) |
---|
301 | m = (l/ml)+1 |
---|
302 | d = l-(m-1)*ml+1 |
---|
303 | ENDIF |
---|
304 | !- |
---|
305 | day = d |
---|
306 | month = m |
---|
307 | year = y |
---|
308 | !------------------------------ |
---|
309 | END SUBROUTINE ju2ymds_internal |
---|
310 | !- |
---|
311 | !=== |
---|
312 | !- |
---|
313 | SUBROUTINE tlen2itau (input_str,dt,date,itau) |
---|
314 | !--------------------------------------------------------------------- |
---|
315 | !- This subroutine transforms a string containing a time length |
---|
316 | !- into a number of time steps. |
---|
317 | !- To do this operation the date (in julian days is needed as the |
---|
318 | !- length of the month varies. |
---|
319 | !- The following convention is used : |
---|
320 | !- n : n time steps |
---|
321 | !- nS : n seconds is transformed into itaus |
---|
322 | !- nH : n hours |
---|
323 | !- nD : n days |
---|
324 | !- nM : n month |
---|
325 | !- nY : n years |
---|
326 | !- Combinations are also possible |
---|
327 | !- nYmD : nyears plus m days ! |
---|
328 | !--------------------------------------------------------------------- |
---|
329 | IMPLICIT NONE |
---|
330 | !- |
---|
331 | CHARACTER(LEN=*),INTENT(IN) :: input_str |
---|
332 | REAL,INTENT(IN) :: dt,date |
---|
333 | !- |
---|
334 | INTEGER,INTENT(OUT) :: itau |
---|
335 | !- |
---|
336 | INTEGER :: y_pos,m_pos,d_pos,h_pos,s_pos |
---|
337 | INTEGER :: read_time |
---|
338 | CHARACTER(LEN=13) :: fmt |
---|
339 | CHARACTER(LEN=80) :: tmp_str |
---|
340 | !- |
---|
341 | INTEGER :: year,month,day |
---|
342 | REAL :: sec,date_new,dd,ss |
---|
343 | !--------------------------------------------------------------------- |
---|
344 | itau = 0 |
---|
345 | CALL ju2ymds (date,year,month,day,sec) |
---|
346 | !- |
---|
347 | y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y')) |
---|
348 | m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M')) |
---|
349 | d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D')) |
---|
350 | h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H')) |
---|
351 | s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S')) |
---|
352 | !- |
---|
353 | IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN |
---|
354 | tmp_str = input_str |
---|
355 | DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0) |
---|
356 | !---- WRITE(*,*) tmp_str |
---|
357 | !---- WRITE(*,*) y_pos,m_pos,d_pos,s_pos |
---|
358 | IF (y_pos > 0) THEN |
---|
359 | WRITE(fmt,'("(I",I10.10,")")') y_pos-1 |
---|
360 | READ(tmp_str(1:y_pos-1),fmt) read_time |
---|
361 | CALL ymds2ju (year+read_time,month,day,sec,date_new) |
---|
362 | dd = date_new-date |
---|
363 | ss = INT(dd)*one_day+dd-INT(dd) |
---|
364 | itau = itau+NINT(ss/dt) |
---|
365 | tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str)) |
---|
366 | ELSE IF (m_pos > 0) THEN |
---|
367 | WRITE(fmt,'("(I",I10.10,")")') m_pos-1 |
---|
368 | READ(tmp_str(1:m_pos-1),fmt) read_time |
---|
369 | CALL ymds2ju (year,month+read_time,day,sec,date_new) |
---|
370 | dd = date_new-date |
---|
371 | ss = INT(dd)*one_day+dd-INT(dd) |
---|
372 | itau = itau+NINT(ss/dt) |
---|
373 | tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str)) |
---|
374 | ELSE IF (d_pos > 0) THEN |
---|
375 | WRITE(fmt,'("(I",I10.10,")")') d_pos-1 |
---|
376 | READ(tmp_str(1:d_pos-1),fmt) read_time |
---|
377 | itau = itau+NINT(read_time*one_day/dt) |
---|
378 | tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) |
---|
379 | ELSE IF (h_pos > 0) THEN |
---|
380 | WRITE(fmt,'("(I",I10.10,")")') h_pos-1 |
---|
381 | READ(tmp_str(1:h_pos-1),fmt) read_time |
---|
382 | itau = itau+NINT(read_time*60.*60./dt) |
---|
383 | tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) |
---|
384 | ELSE IF (s_pos > 0) THEN |
---|
385 | WRITE(fmt,'("(I",I10.10,")")') s_pos-1 |
---|
386 | READ(tmp_str(1:s_pos-1),fmt) read_time |
---|
387 | itau = itau+NINT(read_time/dt) |
---|
388 | tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str)) |
---|
389 | ENDIF |
---|
390 | !- |
---|
391 | y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y')) |
---|
392 | m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M')) |
---|
393 | d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D')) |
---|
394 | h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H')) |
---|
395 | s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S')) |
---|
396 | ENDDO |
---|
397 | ELSE |
---|
398 | WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str) |
---|
399 | READ(input_str(1:LEN_TRIM(input_str)),fmt) itau |
---|
400 | ENDIF |
---|
401 | !----------------------- |
---|
402 | END SUBROUTINE tlen2itau |
---|
403 | !- |
---|
404 | !=== |
---|
405 | !- |
---|
406 | REAL FUNCTION itau2date (itau,date0,deltat) |
---|
407 | !--------------------------------------------------------------------- |
---|
408 | !- This function transforms itau into a date. The date with which |
---|
409 | !- the time axis is going to be labeled |
---|
410 | !- |
---|
411 | !- INPUT |
---|
412 | !- itau : current time step |
---|
413 | !- date0 : Date at which itau was equal to 0 |
---|
414 | !- deltat : time step between itau s |
---|
415 | !- |
---|
416 | !- OUTPUT |
---|
417 | !- itau2date : Date for the given itau |
---|
418 | !--------------------------------------------------------------------- |
---|
419 | IMPLICIT NONE |
---|
420 | !- |
---|
421 | INTEGER :: itau |
---|
422 | REAL :: date0,deltat |
---|
423 | !--------------------------------------------------------------------- |
---|
424 | itau2date = REAL(itau)*deltat/one_day+date0 |
---|
425 | !--------------------- |
---|
426 | END FUNCTION itau2date |
---|
427 | !- |
---|
428 | !=== |
---|
429 | !- |
---|
430 | SUBROUTINE itau2ymds (itau,deltat,year,month,day,sec) |
---|
431 | !--------------------------------------------------------------------- |
---|
432 | !- This subroutine transforms itau into a date. The date with which |
---|
433 | !- the time axis is going to be labeled |
---|
434 | !- |
---|
435 | !- INPUT |
---|
436 | !- itau : current time step |
---|
437 | !- deltat : time step between itau s |
---|
438 | !- |
---|
439 | !- OUTPUT |
---|
440 | !- year : year |
---|
441 | !- month : month |
---|
442 | !- day : day |
---|
443 | !- sec : seconds since midnight |
---|
444 | !--------------------------------------------------------------------- |
---|
445 | IMPLICIT NONE |
---|
446 | !- |
---|
447 | INTEGER,INTENT(IN) :: itau |
---|
448 | REAL,INTENT(IN) :: deltat |
---|
449 | !- |
---|
450 | INTEGER,INTENT(OUT) :: year,month,day |
---|
451 | REAL,INTENT(OUT) :: sec |
---|
452 | !- |
---|
453 | INTEGER :: julian_day |
---|
454 | REAL :: julian_sec |
---|
455 | !--------------------------------------------------------------------- |
---|
456 | IF (.NOT.lock_startdate) THEN |
---|
457 | CALL ipslerr (2,'itau2ymds', & |
---|
458 | & 'You try to call this function, itau2ymds, but you didn''t', & |
---|
459 | & ' call ioconf_startdate to initialize date0 in calendar.', & |
---|
460 | & ' Please call ioconf_startdate before itau2ymds.') |
---|
461 | ENDIF |
---|
462 | julian_day = start_day |
---|
463 | julian_sec = start_sec+REAL(itau)*deltat |
---|
464 | CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) |
---|
465 | !----------------------- |
---|
466 | END SUBROUTINE itau2ymds |
---|
467 | !- |
---|
468 | !=== |
---|
469 | !- |
---|
470 | REAL FUNCTION dtchdate (itau,date0,old_dt,new_dt) |
---|
471 | !--------------------------------------------------------------------- |
---|
472 | !- This function changes the date so that the simulation can |
---|
473 | !- continue with the same itau but a different dt. |
---|
474 | !- |
---|
475 | !- INPUT |
---|
476 | !- itau : current time step |
---|
477 | !- date0 : Date at which itau was equal to 0 |
---|
478 | !- old_dt : Old time step between itaus |
---|
479 | !- new_dt : New time step between itaus |
---|
480 | !- |
---|
481 | !- OUTPUT |
---|
482 | !- dtchdate : Date for the given itau |
---|
483 | !--------------------------------------------------------------------- |
---|
484 | IMPLICIT NONE |
---|
485 | !- |
---|
486 | INTEGER,INTENT(IN) :: itau |
---|
487 | REAL,INTENT(IN) :: date0,old_dt,new_dt |
---|
488 | !- |
---|
489 | REAL :: rtime |
---|
490 | !--------------------------------------------------------------------- |
---|
491 | rtime = itau2date (itau,date0,old_dt) |
---|
492 | dtchdate = rtime-REAL(itau)*new_dt/one_day |
---|
493 | !-------------------- |
---|
494 | END FUNCTION dtchdate |
---|
495 | !- |
---|
496 | !=== |
---|
497 | !- |
---|
498 | SUBROUTINE isittime & |
---|
499 | & (itau,date0,dt,freq,last_action,last_check,do_action) |
---|
500 | !--------------------------------------------------------------------- |
---|
501 | !- This subroutine checks the time as come for a given action. |
---|
502 | !- This is computed from the current time-step(itau). |
---|
503 | !- Thus we need to have the time delta (dt), the frequency |
---|
504 | !- of the action (freq) and the last time it was done |
---|
505 | !- (last_action in units of itau). |
---|
506 | !- In order to extrapolate when will be the next check we need |
---|
507 | !- the time step of the last call (last_check). |
---|
508 | !- |
---|
509 | !- The test is done on the following condition : |
---|
510 | !- the distance from the current time to the time for the next |
---|
511 | !- action is smaller than the one from the next expected |
---|
512 | !- check to the next action. |
---|
513 | !- When the test is done on the time steps simplifactions make |
---|
514 | !- it more difficult to read in the code. |
---|
515 | !- For the real time case it is easier to understand ! |
---|
516 | !--------------------------------------------------------------------- |
---|
517 | IMPLICIT NONE |
---|
518 | !- |
---|
519 | INTEGER,INTENT(IN) :: itau |
---|
520 | REAL,INTENT(IN) :: dt,freq |
---|
521 | INTEGER,INTENT(IN) :: last_action,last_check |
---|
522 | REAL,INTENT(IN) :: date0 |
---|
523 | !- |
---|
524 | LOGICAL,INTENT(OUT) :: do_action |
---|
525 | !- |
---|
526 | REAL :: dt_action,dt_check |
---|
527 | REAL :: date_last_act,date_next_check,date_next_act, & |
---|
528 | & date_now,date_mp1,date_mpf |
---|
529 | INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau |
---|
530 | INTEGER :: yearp,dayp |
---|
531 | REAL :: sec,secp |
---|
532 | LOGICAL :: check = .FALSE. |
---|
533 | !--------------------------------------------------------------------- |
---|
534 | IF (check) THEN |
---|
535 | WRITE(*,*) & |
---|
536 | & "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check |
---|
537 | ENDIF |
---|
538 | !- |
---|
539 | IF (last_check >= 0) THEN |
---|
540 | dt_action = (itau-last_action)*dt |
---|
541 | dt_check = (itau-last_check)*dt |
---|
542 | next_check_itau = itau+(itau-last_check) |
---|
543 | !- |
---|
544 | !-- We are dealing with frequencies in seconds and thus operation |
---|
545 | !-- can be done on the time steps. |
---|
546 | !- |
---|
547 | IF (freq > 0) THEN |
---|
548 | IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN |
---|
549 | do_action = .TRUE. |
---|
550 | ELSE |
---|
551 | do_action = .FALSE. |
---|
552 | ENDIF |
---|
553 | !- |
---|
554 | !---- Here we deal with frequencies in month and work on julian days. |
---|
555 | !- |
---|
556 | ELSE |
---|
557 | date_now = itau2date (itau,date0,dt) |
---|
558 | date_last_act = itau2date (last_action,date0,dt) |
---|
559 | CALL ju2ymds (date_last_act,year,month,day,sec) |
---|
560 | monthp1 = month-freq |
---|
561 | yearp = year |
---|
562 | !- |
---|
563 | !---- Here we compute what logically should be the next month |
---|
564 | !- |
---|
565 | IF (month >= 13) THEN |
---|
566 | yearp = year+1 |
---|
567 | monthp1 = monthp1-12 |
---|
568 | ENDIF |
---|
569 | CALL ymds2ju (year,monthp1,day,sec,date_mpf) |
---|
570 | !- |
---|
571 | !---- But it could be that because of a shorter month or a bad |
---|
572 | !---- starting date that we end up further than we should be. |
---|
573 | !---- Thus we compute the first day of the next month. |
---|
574 | !---- We can not be beyond this date and if we are close |
---|
575 | !---- then we will take it as it is better. |
---|
576 | !- |
---|
577 | monthp1 = month+ABS(freq) |
---|
578 | yearp=year |
---|
579 | IF (monthp1 >= 13) THEN |
---|
580 | yearp = year+1 |
---|
581 | monthp1 = monthp1 -12 |
---|
582 | ENDIF |
---|
583 | dayp = 1 |
---|
584 | secp = 0.0 |
---|
585 | CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1) |
---|
586 | !- |
---|
587 | !---- If date_mp1 is smaller than date_mpf or only less than 4 days |
---|
588 | !---- larger then we take it. This needed to ensure that short month |
---|
589 | !---- like February do not mess up the thing ! |
---|
590 | !- |
---|
591 | IF (date_mp1-date_mpf < 4.) THEN |
---|
592 | date_next_act = date_mp1 |
---|
593 | ELSE |
---|
594 | date_next_act = date_mpf |
---|
595 | ENDIF |
---|
596 | date_next_check = itau2date (next_check_itau,date0,dt) |
---|
597 | !- |
---|
598 | !---- Transform the dates into time-steps for the needed precisions. |
---|
599 | !- |
---|
600 | next_act_itau = & |
---|
601 | & last_action+INT((date_next_act-date_last_act)*(one_day/dt)) |
---|
602 | !----- |
---|
603 | IF ( ABS(itau-next_act_itau) & |
---|
604 | & <= ABS( next_check_itau-next_act_itau)) THEN |
---|
605 | do_action = .TRUE. |
---|
606 | IF (check) THEN |
---|
607 | WRITE(*,*) & |
---|
608 | & 'ACT-TIME : itau, next_act_itau, next_check_itau : ', & |
---|
609 | & itau,next_act_itau,next_check_itau |
---|
610 | CALL ju2ymds (date_now,year,month,day,sec) |
---|
611 | WRITE(*,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec |
---|
612 | WRITE(*,*) & |
---|
613 | & 'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf |
---|
614 | ENDIF |
---|
615 | ELSE |
---|
616 | do_action = .FALSE. |
---|
617 | ENDIF |
---|
618 | ENDIF |
---|
619 | !- |
---|
620 | IF (check) THEN |
---|
621 | WRITE(*,*) "isittime 2.0 ", & |
---|
622 | & date_next_check,date_next_act,ABS(dt_action-freq), & |
---|
623 | & ABS(dt_action+dt_check-freq),dt_action,dt_check, & |
---|
624 | & next_check_itau,do_action |
---|
625 | ENDIF |
---|
626 | ELSE |
---|
627 | do_action=.FALSE. |
---|
628 | ENDIF |
---|
629 | !---------------------- |
---|
630 | END SUBROUTINE isittime |
---|
631 | !- |
---|
632 | !=== |
---|
633 | !- |
---|
634 | SUBROUTINE ioconf_calendar (str) |
---|
635 | !--------------------------------------------------------------------- |
---|
636 | !- This routine allows to configure the calendar to be used. |
---|
637 | !- This operation is only allowed once and the first call to |
---|
638 | !- ymds2ju or ju2ymsd will lock the current configuration. |
---|
639 | !- the argument to ioconf_calendar can be any of the following : |
---|
640 | !- - gregorian : This is the gregorian calendar (default here) |
---|
641 | !- - noleap : A calendar without leap years = 365 days |
---|
642 | !- - xxxd : A calendar of xxx days (has to be a modulo of 12) |
---|
643 | !- with 12 month of equal length |
---|
644 | !--------------------------------------------------------------------- |
---|
645 | IMPLICIT NONE |
---|
646 | !- |
---|
647 | CHARACTER(LEN=*),INTENT(IN) :: str |
---|
648 | !- |
---|
649 | INTEGER :: leng,ipos |
---|
650 | CHARACTER(LEN=20) :: str_w |
---|
651 | !--------------------------------------------------------------------- |
---|
652 | !- |
---|
653 | ! Clean up the string ! |
---|
654 | !- |
---|
655 | str_w = str |
---|
656 | CALL strlowercase (str_w) |
---|
657 | !- |
---|
658 | IF (.NOT.lock_one_year) THEN |
---|
659 | !--- |
---|
660 | lock_one_year=.TRUE. |
---|
661 | !--- |
---|
662 | SELECT CASE(TRIM(str_w)) |
---|
663 | CASE('gregorian','standard','proleptic_gregorian') |
---|
664 | calendar_used = 'gregorian' |
---|
665 | one_year = 365.2425 |
---|
666 | mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) |
---|
667 | CASE('noleap','365_day','365d') |
---|
668 | calendar_used = 'noleap' |
---|
669 | one_year = 365.0 |
---|
670 | mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) |
---|
671 | CASE('all_leap','366_day','366d') |
---|
672 | calendar_used = 'all_leap' |
---|
673 | one_year = 366.0 |
---|
674 | mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/) |
---|
675 | CASE('360_day','360d') |
---|
676 | calendar_used = '360d' |
---|
677 | one_year = 360.0 |
---|
678 | mon_len(:)=(/30,30,30,30,30,30,30,30,30,30,30,30/) |
---|
679 | CASE('julian') |
---|
680 | calendar_used = 'julian' |
---|
681 | one_year = 365.25 |
---|
682 | mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) |
---|
683 | CASE DEFAULT |
---|
684 | ipos = INDEX(str_w,'d') |
---|
685 | IF (ipos == 4) THEN |
---|
686 | READ(str_w(1:3),'(I3)') leng |
---|
687 | IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN |
---|
688 | calendar_used = str_w |
---|
689 | one_year = leng |
---|
690 | mon_len(:) = leng/12 |
---|
691 | ELSE |
---|
692 | CALL ipslerr (3,'ioconf_calendar', & |
---|
693 | & 'The length of the year as to be a modulo of 12', & |
---|
694 | & 'so that it can be divided into 12 month of equal length', & |
---|
695 | & TRIM(str_w)) |
---|
696 | ENDIF |
---|
697 | ELSE |
---|
698 | CALL ipslerr (3,'ioconf_calendar', & |
---|
699 | & 'Unrecognized input, please check the man pages.', & |
---|
700 | & TRIM(str_w),' ') |
---|
701 | ENDIF |
---|
702 | END SELECT |
---|
703 | ELSE IF (TRIM(str_w) /= TRIM(calendar_used)) THEN |
---|
704 | WRITE(str_w,'(f10.4)') one_year |
---|
705 | CALL ipslerr (2,'ioconf_calendar', & |
---|
706 | & 'The calendar was already used or configured to : '// & |
---|
707 | & TRIM(calendar_used)//'.', & |
---|
708 | & 'You are not allowed to change it to : '//TRIM(str)//'.', & |
---|
709 | & 'The following length of year is used : '//TRIM(ADJUSTL(str_w))) |
---|
710 | ENDIF |
---|
711 | !----------------------------- |
---|
712 | END SUBROUTINE ioconf_calendar |
---|
713 | !- |
---|
714 | !=== |
---|
715 | !- |
---|
716 | SUBROUTINE ioconf_startdate_simple (julian) |
---|
717 | !--------------------------------------------------------------------- |
---|
718 | IMPLICIT NONE |
---|
719 | !- |
---|
720 | REAL,INTENT(IN) :: julian |
---|
721 | !- |
---|
722 | INTEGER :: julian_day |
---|
723 | REAL :: julian_sec |
---|
724 | !--------------------------------------------------------------------- |
---|
725 | julian_day = INT(julian) |
---|
726 | julian_sec = (julian-julian_day)*one_day |
---|
727 | !- |
---|
728 | CALL ioconf_startdate_internal (julian_day,julian_sec) |
---|
729 | !------------------------------------- |
---|
730 | END SUBROUTINE ioconf_startdate_simple |
---|
731 | !- |
---|
732 | !=== |
---|
733 | !- |
---|
734 | SUBROUTINE ioconf_startdate_ymds (year,month,day,sec) |
---|
735 | !--------------------------------------------------------------------- |
---|
736 | IMPLICIT NONE |
---|
737 | !- |
---|
738 | INTEGER,INTENT(IN) :: year,month,day |
---|
739 | REAL,INTENT(IN) :: sec |
---|
740 | !- |
---|
741 | INTEGER :: julian_day |
---|
742 | REAL :: julian_sec |
---|
743 | !--------------------------------------------------------------------- |
---|
744 | CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) |
---|
745 | !- |
---|
746 | CALL ioconf_startdate_internal (julian_day,julian_sec) |
---|
747 | !----------------------------------- |
---|
748 | END SUBROUTINE ioconf_startdate_ymds |
---|
749 | !- |
---|
750 | !=== |
---|
751 | !- |
---|
752 | SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec) |
---|
753 | !--------------------------------------------------------------------- |
---|
754 | ! This subroutine allows to set the startdate for later |
---|
755 | ! use. It allows the applications to access the date directly from |
---|
756 | ! the timestep. In order to avoid any problems the start date will |
---|
757 | ! be locked and can not be changed once set. |
---|
758 | !--------------------------------------------------------------------- |
---|
759 | IMPLICIT NONE |
---|
760 | !- |
---|
761 | INTEGER,INTENT(IN) :: julian_day |
---|
762 | REAL,INTENT(IN) :: julian_sec |
---|
763 | !- |
---|
764 | CHARACTER(len=70) :: str70a,str70b |
---|
765 | !--------------------------------------------------------------------- |
---|
766 | IF (.NOT.lock_startdate) THEN |
---|
767 | start_day = julian_day |
---|
768 | start_sec = julian_sec |
---|
769 | lock_startdate = .TRUE. |
---|
770 | ELSE |
---|
771 | WRITE(str70a,'("The date you tried to set : ",f10.4)') & |
---|
772 | & julian_day,julian_sec/one_day |
---|
773 | WRITE(str70b, & |
---|
774 | & '("The date which was already set in the calendar : ",f10.4)') & |
---|
775 | & start_day+start_sec/one_day |
---|
776 | CALL ipslerr (2,'ioconf_startdate', & |
---|
777 | & 'The start date has already been set and you tried to change it', & |
---|
778 | & str70a,str70b) |
---|
779 | ENDIF |
---|
780 | !--------------------------------------- |
---|
781 | END SUBROUTINE ioconf_startdate_internal |
---|
782 | !- |
---|
783 | !=== |
---|
784 | !- |
---|
785 | SUBROUTINE ioget_calendar_str (str) |
---|
786 | !--------------------------------------------------------------------- |
---|
787 | !- This subroutine returns the name of the calendar used here. |
---|
788 | !- Three options exist : |
---|
789 | !- - gregorian : This is the gregorian calendar (default here) |
---|
790 | !- - noleap : A calendar without leap years = 365 days |
---|
791 | !- - xxxd : A calendar of xxx days (has to be a modulo of 12) |
---|
792 | !- with 12 month of equal length |
---|
793 | !- |
---|
794 | !- This routine will lock the calendar. |
---|
795 | !- You do not want it to change after your inquiry. |
---|
796 | !--------------------------------------------------------------------- |
---|
797 | IMPLICIT NONE |
---|
798 | !- |
---|
799 | CHARACTER(LEN=*),INTENT(OUT) :: str |
---|
800 | !--------------------------------------------------------------------- |
---|
801 | lock_one_year = .TRUE. |
---|
802 | !- |
---|
803 | str = calendar_used |
---|
804 | !-------------------------------- |
---|
805 | END SUBROUTINE ioget_calendar_str |
---|
806 | !- |
---|
807 | !=== |
---|
808 | !- |
---|
809 | SUBROUTINE ioget_calendar_real1 (long_year) |
---|
810 | !--------------------------------------------------------------------- |
---|
811 | !- This subroutine returns the name of the calendar used here. |
---|
812 | !- Three options exist : |
---|
813 | !- - gregorian : This is the gregorian calendar (default here) |
---|
814 | !- - noleap : A calendar without leap years = 365 days |
---|
815 | !- - xxxd : A calendar of xxx days (has to be a modulo of 12) |
---|
816 | !- with 12 month of equal length |
---|
817 | !- |
---|
818 | !- This routine will lock the calendar. |
---|
819 | !- You do not want it to change after your inquiry. |
---|
820 | !--------------------------------------------------------------------- |
---|
821 | IMPLICIT NONE |
---|
822 | !- |
---|
823 | REAL,INTENT(OUT) :: long_year |
---|
824 | !--------------------------------------------------------------------- |
---|
825 | long_year = one_year |
---|
826 | lock_one_year = .TRUE. |
---|
827 | !---------------------------------- |
---|
828 | END SUBROUTINE ioget_calendar_real1 |
---|
829 | !- |
---|
830 | !=== |
---|
831 | !- |
---|
832 | SUBROUTINE ioget_calendar_real2 (long_year,long_day) |
---|
833 | !--------------------------------------------------------------------- |
---|
834 | !- This subroutine returns the name of the calendar used here. |
---|
835 | !- Three options exist : |
---|
836 | !- - gregorian : This is the gregorian calendar (default here) |
---|
837 | !- - noleap : A calendar without leap years = 365 days |
---|
838 | !- - xxxd : A calendar of xxx days (has to be a modulo of 12) |
---|
839 | !- with 12 month of equal length |
---|
840 | !- |
---|
841 | !- This routine will lock the calendar. |
---|
842 | !- You do not want it to change after your inquiry. |
---|
843 | !--------------------------------------------------------------------- |
---|
844 | IMPLICIT NONE |
---|
845 | !- |
---|
846 | REAL,INTENT(OUT) :: long_year,long_day |
---|
847 | !--------------------------------------------------------------------- |
---|
848 | long_year = one_year |
---|
849 | long_day = one_day |
---|
850 | lock_one_year = .TRUE. |
---|
851 | !---------------------------------- |
---|
852 | END SUBROUTINE ioget_calendar_real2 |
---|
853 | !- |
---|
854 | !=== |
---|
855 | !- |
---|
856 | INTEGER FUNCTION ioget_mon_len (year,month) |
---|
857 | !!-------------------------------------------------------------------- |
---|
858 | !! The "ioget_mon_len" function returns |
---|
859 | !! the number of days in a "month" of a "year", |
---|
860 | !! in the current calendar. |
---|
861 | !! |
---|
862 | !! INTEGER FUNCTION ioget_mon_len (year,month) |
---|
863 | !! |
---|
864 | !! INPUT |
---|
865 | !! |
---|
866 | !! (I) year : year |
---|
867 | !! (I) month : month in the year (1 --> 12) |
---|
868 | !! |
---|
869 | !! OUTPUT |
---|
870 | !! |
---|
871 | !! (I) ioget_mon_len : number of days in the month |
---|
872 | !!-------------------------------------------------------------------- |
---|
873 | IMPLICIT NONE |
---|
874 | !- |
---|
875 | INTEGER,INTENT(IN) :: year,month |
---|
876 | !- |
---|
877 | INTEGER :: ml |
---|
878 | !--------------------------------------------------------------------- |
---|
879 | IF ( (month >= 1).AND.(month <= 12) ) THEN |
---|
880 | IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN |
---|
881 | !---- "Gregorian" or "Julian" |
---|
882 | ml = mon_len(month) |
---|
883 | IF (month == 2) THEN |
---|
884 | IF (ABS(one_year-365.2425) <= EPSILON(one_year) ) THEN |
---|
885 | !-------- "Gregorian" |
---|
886 | IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & |
---|
887 | .OR.(MOD(year,400) == 0) ) THEN |
---|
888 | ml = ml+1 |
---|
889 | ENDIF |
---|
890 | ELSE |
---|
891 | !-------- "Julian" |
---|
892 | IF (MOD(year,4) == 0) THEN |
---|
893 | ml = ml+1 |
---|
894 | ENDIF |
---|
895 | ENDIF |
---|
896 | ENDIF |
---|
897 | ioget_mon_len = ml |
---|
898 | ELSE |
---|
899 | !---- "No leap" or "All leap" or "Calendar with regular month" |
---|
900 | ioget_mon_len = mon_len(month) |
---|
901 | ENDIF |
---|
902 | ELSE |
---|
903 | CALL ipslerr (3,'ioget_mon_len', & |
---|
904 | & 'The number of the month','must be between','1 and 12') |
---|
905 | ENDIF |
---|
906 | !------------------------- |
---|
907 | END FUNCTION ioget_mon_len |
---|
908 | !- |
---|
909 | !=== |
---|
910 | !- |
---|
911 | INTEGER FUNCTION ioget_year_len (year) |
---|
912 | !!-------------------------------------------------------------------- |
---|
913 | !! The "ioget_year_len" function returns |
---|
914 | !! the number of days in "year", in the current calendar. |
---|
915 | !! |
---|
916 | !! INTEGER FUNCTION ioget_year_len (year) |
---|
917 | !! |
---|
918 | !! INPUT |
---|
919 | !! |
---|
920 | !! (I) year : year |
---|
921 | !! |
---|
922 | !! OUTPUT |
---|
923 | !! |
---|
924 | !! (I) ioget_year_len : number of days in the year |
---|
925 | !!-------------------------------------------------------------------- |
---|
926 | IMPLICIT NONE |
---|
927 | !- |
---|
928 | INTEGER,INTENT(IN) :: year |
---|
929 | !- |
---|
930 | INTEGER :: yl |
---|
931 | !--------------------------------------------------------------------- |
---|
932 | SELECT CASE(TRIM(calendar_used)) |
---|
933 | CASE('gregorian') |
---|
934 | yl = 365 |
---|
935 | IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & |
---|
936 | .OR.(MOD(year,400) == 0) ) THEN |
---|
937 | yl = yl+1 |
---|
938 | ENDIF |
---|
939 | CASE('julian') |
---|
940 | yl = 365 |
---|
941 | IF (MOD(year,4) == 0) THEN |
---|
942 | yl = yl+1 |
---|
943 | ENDIF |
---|
944 | CASE DEFAULT |
---|
945 | yl = NINT(one_year) |
---|
946 | END SELECT |
---|
947 | ioget_year_len = yl |
---|
948 | !-------------------------- |
---|
949 | END FUNCTION ioget_year_len |
---|
950 | !- |
---|
951 | !=== |
---|
952 | !- |
---|
953 | SUBROUTINE ioget_timestamp (string) |
---|
954 | !--------------------------------------------------------------------- |
---|
955 | IMPLICIT NONE |
---|
956 | !- |
---|
957 | CHARACTER(LEN=30),INTENT(OUT) :: string |
---|
958 | !- |
---|
959 | INTEGER :: date_time(8) |
---|
960 | CHARACTER(LEN=10) :: bigben(3) |
---|
961 | !--------------------------------------------------------------------- |
---|
962 | IF (INDEX(time_stamp,'XXXXXX') > 0) THEN |
---|
963 | CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time) |
---|
964 | !--- |
---|
965 | WRITE(time_stamp, & |
---|
966 | & "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") & |
---|
967 | & date_time(1),cal(date_time(2)),date_time(3),date_time(5), & |
---|
968 | & date_time(6),date_time(7),bigben(3) |
---|
969 | ENDIF |
---|
970 | !- |
---|
971 | string = time_stamp |
---|
972 | !----------------------------- |
---|
973 | END SUBROUTINE ioget_timestamp |
---|
974 | !- |
---|
975 | !=== |
---|
976 | !- |
---|
977 | SUBROUTINE time_add & |
---|
978 | & (year_s,month_s,day_s,sec_s,sec_increment, & |
---|
979 | & year_e,month_e,day_e,sec_e) |
---|
980 | !--------------------------------------------------------------------- |
---|
981 | !- This subroutine allows to increment a date by a number of seconds. |
---|
982 | !--------------------------------------------------------------------- |
---|
983 | IMPLICIT NONE |
---|
984 | !- |
---|
985 | INTEGER,INTENT(IN) :: year_s,month_s,day_s |
---|
986 | REAL,INTENT(IN) :: sec_s |
---|
987 | !- |
---|
988 | ! Time in seconds to be added to the date |
---|
989 | !- |
---|
990 | REAL,INTENT(IN) :: sec_increment |
---|
991 | !- |
---|
992 | INTEGER,INTENT(OUT) :: year_e,month_e,day_e |
---|
993 | REAL,INTENT(OUT) :: sec_e |
---|
994 | !- |
---|
995 | INTEGER :: julian_day |
---|
996 | REAL :: julian_sec |
---|
997 | !--------------------------------------------------------------------- |
---|
998 | CALL ymds2ju_internal & |
---|
999 | & (year_s,month_s,day_s,sec_s,julian_day,julian_sec) |
---|
1000 | !- |
---|
1001 | julian_sec = julian_sec+sec_increment |
---|
1002 | !- |
---|
1003 | CALL ju2ymds_internal & |
---|
1004 | & (julian_day,julian_sec,year_e,month_e,day_e,sec_e) |
---|
1005 | !---------------------- |
---|
1006 | END SUBROUTINE time_add |
---|
1007 | !- |
---|
1008 | !=== |
---|
1009 | !- |
---|
1010 | SUBROUTINE time_diff & |
---|
1011 | & (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff) |
---|
1012 | !--------------------------------------------------------------------- |
---|
1013 | !- This subroutine allows to determine the number of seconds |
---|
1014 | !- between two dates. |
---|
1015 | !--------------------------------------------------------------------- |
---|
1016 | IMPLICIT NONE |
---|
1017 | !- |
---|
1018 | INTEGER,INTENT(IN) :: year_s,month_s,day_s |
---|
1019 | REAL,INTENT(IN) :: sec_s |
---|
1020 | INTEGER,INTENT(IN) :: year_e,month_e,day_e |
---|
1021 | REAL,INTENT(IN) :: sec_e |
---|
1022 | !- |
---|
1023 | ! Time in seconds between the two dates |
---|
1024 | !- |
---|
1025 | REAL,INTENT(OUT) :: sec_diff |
---|
1026 | !- |
---|
1027 | INTEGER :: julian_day_s,julian_day_e,day_diff |
---|
1028 | REAL :: julian_sec_s,julian_sec_e |
---|
1029 | !--------------------------------------------------------------------- |
---|
1030 | CALL ymds2ju_internal & |
---|
1031 | & (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s) |
---|
1032 | CALL ymds2ju_internal & |
---|
1033 | & (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e) |
---|
1034 | !- |
---|
1035 | day_diff = julian_day_e-julian_day_s |
---|
1036 | sec_diff = julian_sec_e-julian_sec_s |
---|
1037 | !- |
---|
1038 | sec_diff = sec_diff+day_diff*one_day |
---|
1039 | !----------------------- |
---|
1040 | END SUBROUTINE time_diff |
---|
1041 | !- |
---|
1042 | !=== |
---|
1043 | !- |
---|
1044 | END MODULE calendar |
---|