Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_date_time.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 31.2 KB

Line
1	!WRF:MODEL_LAYER:UTIL
2	!
3	MODULE module_date_time
4
5	USE module_wrf_error
6	USE module_configure
7	USE module_model_constants
8
9	CHARACTER* 24 :: start_date = ' '
10	CHARACTER* 24 :: current_date
11	INTEGER , PARAMETER :: len_current_date = 24
12	REAL , PRIVATE :: xtime
13
14	! 1. geth_idts (ndate, odate, idts)
15	! Get the time period between two dates.
16
17	! 2. geth_newdate ( ndate, odate, idts)
18	! Get the new date based on the old date and a time difference.
19
20	! 3. split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth)
21	! Given the date, return the integer components.
22
23	CONTAINS
24
25	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
26
27	SUBROUTINE get_julgmt(date_str,julyr,julday,gmt)
28	IMPLICIT NONE
29	! Arguments
30	CHARACTER (LEN=24) , INTENT(IN) :: date_str
31	INTEGER, INTENT(OUT ) :: julyr
32	INTEGER, INTENT(OUT ) :: julday
33	REAL , INTENT(OUT ) :: gmt
34	! Local
35	INTEGER :: ny , nm , nd , nh , ni , ns , nt
36	INTEGER :: my1, my2, my3, monss
37	INTEGER, DIMENSION(12) :: mmd
38	DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/
39	CALL split_date_char ( date_str , ny , nm , nd , nh , ni , ns , nt )
40	#ifdef PLANET
41	GMT=nh+FLOAT(ni)/60.+(FLOAT(ns)+FLOAT(nt)/1.e6)/3600.
42	JULDAY=nd
43	JULYR=ny
44	#else
45	GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600.
46	MY1=MOD(ny,4)
47	MY2=MOD(ny,100)
48	MY3=MOD(ny,400)
49	IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29
50	JULDAY=nd
51	JULYR=ny
52	DO MONSS=1,nm-1
53	JULDAY=JULDAY+MMD(MONSS)
54	ENDDO
55	#endif
56	END SUBROUTINE get_julgmt
57
58
59	SUBROUTINE geth_julgmt(julyr,julday, gmt)
60	IMPLICIT NONE
61	! Arguments
62	INTEGER, INTENT(OUT ) :: julyr
63	INTEGER, INTENT(OUT ) :: julday
64	REAL , INTENT(OUT ) :: gmt
65	! Local
66	INTEGER :: ny , nm , nd , nh , ni , ns , nt
67	INTEGER :: my1, my2, my3, monss
68	INTEGER, DIMENSION(12) :: mmd
69	DATA MMD/31,28,31,30,31,30,31,31,30,31,30,31/
70	CALL split_date_char ( current_date , ny , nm , nd , nh , ni , ns , nt )
71	#ifdef PLANET
72	GMT=nh+FLOAT(ni)/60.+(FLOAT(ns)+FLOAT(nt)/1.e6)/3600.
73	JULDAY=nd
74	JULYR=ny
75	#else
76	GMT=nh+FLOAT(ni)/60.+FLOAT(ns)/3600.
77	MY1=MOD(ny,4)
78	MY2=MOD(ny,100)
79	MY3=MOD(ny,400)
80	IF(MY1.EQ.0.AND.MY2.NE.0.OR.MY3.EQ.0)MMD(2)=29
81	JULDAY=nd
82	JULYR=ny
83	DO MONSS=1,nm-1
84	JULDAY=JULDAY+MMD(MONSS)
85	ENDDO
86	#endif
87	END SUBROUTINE geth_julgmt
88
89	SUBROUTINE calc_current_date (id, time)
90	! This subroutines calculates current_date and xtime
91	IMPLICIT NONE
92	! Arguments
93	INTEGER, INTENT(IN ) :: id ! grid id
94	REAL, INTENT(IN ) :: time ! time in seconds since start time
95	! Local
96	INTEGER :: julyr, julday, idt
97	CHARACTER*19 new_date
98	CHARACTER*24 base_date
99	CHARACTER*128 mess
100	REAL :: gmt
101
102	xtime = time/60.
103	CALL nl_get_gmt (id, gmt)
104	CALL nl_get_julyr (id, julyr)
105	CALL nl_get_julday (id, julday)
106	idt = 86400(julday-1)+nint(3600gmt)
107	write (mess,*) 'calc_current_date called: time = ',time,' idt = ',idt
108	CALL wrf_debug(300,TRIM(mess))
109	write (mess,*) 'calc_current_date called: gmt = ',gmt
110	CALL wrf_debug(300,TRIM(mess))
111	write (mess,*) 'calc_current_date called: julyr = ',julyr
112	CALL wrf_debug(300,TRIM(mess))
113	write (mess,*) 'calc_current_date called: julday = ',julday
114	CALL wrf_debug(300,TRIM(mess))
115	#ifdef PLANET
116	base_date = '0000-00001_00:00:00.0000'
117	#else
118	base_date = '0000-01-01_00:00:00.0000'
119	#endif
120	write(base_date(1:4),'(I4.4)')julyr
121	CALL geth_newdate (start_date(1:19), base_date(1:19), idt)
122	CALL geth_newdate (new_date, start_date(1:19), nint(time))
123	write (current_date(1:24),fmt=340)new_date
124	340 format(a19, '.0000')
125	write (mess,*) current_date,gmt,julday,julyr,'=current_date,gmt,julday,julyr: calc_current_date'
126	CALL wrf_debug(300,TRIM(mess))
127	END SUBROUTINE calc_current_date
128
129	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
130
131	SUBROUTINE geth_idts (ndate, odate, idts)
132
133	IMPLICIT NONE
134
135	! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'),
136	! or ('YYYY-DDDDD HH:MM:SS.ffff'),
137	! compute the time difference.
138
139	! on entry - ndate - the new hdate.
140	! odate - the old hdate.
141
142	! on exit - idts - the change in time in seconds.
143
144	CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate
145	INTEGER , INTENT(OUT) :: idts
146
147	! Local Variables
148
149	! yrnew - indicates the year associated with "ndate"
150	! yrold - indicates the year associated with "odate"
151	! monew - indicates the month associated with "ndate"
152	! moold - indicates the month associated with "odate"
153	! dynew - indicates the day associated with "ndate"
154	! dyold - indicates the day associated with "odate"
155	! hrnew - indicates the hour associated with "ndate"
156	! hrold - indicates the hour associated with "odate"
157	! minew - indicates the minute associated with "ndate"
158	! miold - indicates the minute associated with "odate"
159	! scnew - indicates the second associated with "ndate"
160	! scold - indicates the second associated with "odate"
161	! i - loop counter
162	! mday - a list assigning the number of days in each month
163
164	CHARACTER (LEN=24) :: tdate
165	INTEGER :: olen, nlen
166	INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew
167	INTEGER :: yrold, moold, dyold, hrold, miold, scold
168	INTEGER :: mday(12), i, newdys, olddys
169	LOGICAL :: npass, opass
170	INTEGER :: isign
171
172	IF (odate.GT.ndate) THEN
173	isign = -1
174	tdate=ndate
175	ndate=odate
176	odate=tdate
177	ELSE
178	isign = 1
179	END IF
180
181	! Assign the number of days in a months
182
183	mday( 1) = 31
184	mday( 2) = 28
185	mday( 3) = 31
186	mday( 4) = 30
187	mday( 5) = 31
188	mday( 6) = 30
189	mday( 7) = 31
190	mday( 8) = 31
191	mday( 9) = 30
192	mday(10) = 31
193	mday(11) = 30
194	mday(12) = 31
195
196	! Break down old hdate into parts
197
198	hrold = 0
199	miold = 0
200	scold = 0
201	olen = LEN(odate)
202
203	READ(odate(1:4), '(I4)') yrold
204	#ifdef PLANET
205	READ(odate(6:10), '(I5)') dyold
206	moold=0.
207	#else
208	READ(odate(6:7), '(I2)') moold
209	READ(odate(9:10), '(I2)') dyold
210	#endif
211	IF (olen.GE.13) THEN
212	READ(odate(12:13),'(I2)') hrold
213	IF (olen.GE.16) THEN
214	READ(odate(15:16),'(I2)') miold
215	IF (olen.GE.19) THEN
216	READ(odate(18:19),'(I2)') scold
217	END IF
218	END IF
219	END IF
220
221	! Break down new hdate into parts
222
223	hrnew = 0
224	minew = 0
225	scnew = 0
226	nlen = LEN(ndate)
227
228	READ(ndate(1:4), '(I4)') yrnew
229	#ifdef PLANET
230	READ(ndate(6:10), '(I5)') dynew
231	monew=0.
232	#else
233	READ(ndate(6:7), '(I2)') monew
234	READ(ndate(9:10), '(I2)') dynew
235	#endif
236	IF (nlen.GE.13) THEN
237	READ(ndate(12:13),'(I2)') hrnew
238	IF (nlen.GE.16) THEN
239	READ(ndate(15:16),'(I2)') minew
240	IF (nlen.GE.19) THEN
241	READ(ndate(18:19),'(I2)') scnew
242	END IF
243	END IF
244	END IF
245
246	! Check that the dates make sense.
247
248	npass = .true.
249	opass = .true.
250
251	#ifdef PLANET
252	! Check that the day of NDATE makes sense.
253
254	IF ((dynew > PLANET_YEAR).or.(dynew < 1)) THEN
255	PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew
256	npass = .false.
257	END IF
258
259	! Check that the day of ODATE makes sense.
260
261	IF ((dyold > PLANET_YEAR).or.(dyold < 1)) THEN
262	PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold
263	opass = .false.
264	END IF
265
266	#else
267	! Check that the month of NDATE makes sense.
268
269	IF ((monew.GT.12).or.(monew.LT.1)) THEN
270	PRINT*, 'GETH_IDTS: Month of NDATE = ', monew
271	npass = .false.
272	END IF
273
274	! Check that the month of ODATE makes sense.
275
276	IF ((moold.GT.12).or.(moold.LT.1)) THEN
277	PRINT*, 'GETH_IDTS: Month of ODATE = ', moold
278	opass = .false.
279	END IF
280
281	! Check that the day of NDATE makes sense.
282
283	IF (monew.ne.2) THEN
284	! ...... For all months but February
285	IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN
286	PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew
287	npass = .false.
288	END IF
289	ELSE IF (monew.eq.2) THEN
290	! ...... For February
291	IF ((dynew.GT.nfeb(yrnew)).OR.(dynew.LT.1)) THEN
292	PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew
293	npass = .false.
294	END IF
295	END IF
296
297	! Check that the day of ODATE makes sense.
298
299	IF (moold.ne.2) THEN
300	! ...... For all months but February
301	IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
302	PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold
303	opass = .false.
304	END IF
305	ELSE IF (moold.eq.2) THEN
306	! ....... For February
307	IF ((dyold.GT.nfeb(yrold)).or.(dyold.LT.1)) THEN
308	PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold
309	opass = .false.
310	END IF
311	END IF
312	#endif
313	! Check that the hour of NDATE makes sense.
314
315	IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN
316	PRINT*, 'GETH_IDTS: Hour of NDATE = ', hrnew
317	npass = .false.
318	END IF
319
320	! Check that the hour of ODATE makes sense.
321
322	IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
323	PRINT*, 'GETH_IDTS: Hour of ODATE = ', hrold
324	opass = .false.
325	END IF
326
327	! Check that the minute of NDATE makes sense.
328
329	IF ((minew.GT.59).or.(minew.LT.0)) THEN
330	PRINT*, 'GETH_IDTS: Minute of NDATE = ', minew
331	npass = .false.
332	END IF
333
334	! Check that the minute of ODATE makes sense.
335
336	IF ((miold.GT.59).or.(miold.LT.0)) THEN
337	PRINT*, 'GETH_IDTS: Minute of ODATE = ', miold
338	opass = .false.
339	END IF
340
341	! Check that the second of NDATE makes sense.
342
343	IF ((scnew.GT.59).or.(scnew.LT.0)) THEN
344	PRINT*, 'GETH_IDTS: SECOND of NDATE = ', scnew
345	npass = .false.
346	END IF
347
348	! Check that the second of ODATE makes sense.
349
350	IF ((scold.GT.59).or.(scold.LT.0)) THEN
351	PRINT*, 'GETH_IDTS: Second of ODATE = ', scold
352	opass = .false.
353	END IF
354
355	IF (.not. npass) THEN
356	WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad NDATE: ', ndate(1:nlen)
357	CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
358	END IF
359
360	IF (.not. opass) THEN
361	WRITE( wrf_err_message , * ) 'module_date_time: geth_idts: Bad ODATE: ', odate(1:olen)
362	CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
363	END IF
364
365	! Date Checks are completed. Continue.
366
367	! Compute number of days from 1 January ODATE, 00:00:00 until ndate
368	! Compute number of hours from 1 January ODATE, 00:00:00 until ndate
369	! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
370
371	newdys = 0
372	#ifdef PLANET
373	DO i = yrold, yrnew - 1
374	newdys = newdys + PLANET_YEAR
375	END DO
376	#else
377	DO i = yrold, yrnew - 1
378	newdys = newdys + (365 + (nfeb(i)-28))
379	END DO
380
381	IF (monew .GT. 1) THEN
382	mday(2) = nfeb(yrnew)
383	DO i = 1, monew - 1
384	newdys = newdys + mday(i)
385	END DO
386	mday(2) = 28
387	END IF
388	#endif
389
390	newdys = newdys + dynew-1
391
392	! Compute number of hours from 1 January ODATE, 00:00:00 until odate
393	! Compute number of minutes from 1 January ODATE, 00:00:00 until odate
394
395	olddys = 0
396
397	#ifndef PLANET
398	IF (moold .GT. 1) THEN
399	mday(2) = nfeb(yrold)
400	DO i = 1, moold - 1
401	olddys = olddys + mday(i)
402	END DO
403	mday(2) = 28
404	END IF
405	#endif
406
407	olddys = olddys + dyold-1
408
409	! Determine the time difference in seconds
410
411	idts = (newdys - olddys) * 86400
412	idts = idts + (hrnew - hrold) * 3600
413	idts = idts + (minew - miold) * 60
414	idts = idts + (scnew - scold)
415
416	IF (isign .eq. -1) THEN
417	tdate=ndate
418	ndate=odate
419	odate=tdate
420	idts = idts * isign
421	END IF
422
423	END SUBROUTINE geth_idts
424
425	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
426
427	SUBROUTINE geth_newdate (ndate, odate, idt)
428
429	IMPLICIT NONE
430
431	! From old date ('YYYY-MM-DD HH:MM:SS.ffff') and
432	! [or ('YYYY-DDDDD HH:MM:SS.ffff')]
433	! delta-time, compute the new date.
434
435	! on entry - odate - the old hdate.
436	! idt - the change in time
437
438	! on exit - ndate - the new hdate.
439
440	INTEGER , INTENT(IN) :: idt
441	CHARACTER (LEN=*) , INTENT(OUT) :: ndate
442	CHARACTER (LEN=*) , INTENT(IN) :: odate
443
444
445	! Local Variables
446
447	! yrold - indicates the year associated with "odate"
448	! moold - indicates the month associated with "odate"
449	! dyold - indicates the day associated with "odate"
450	! hrold - indicates the hour associated with "odate"
451	! miold - indicates the minute associated with "odate"
452	! scold - indicates the second associated with "odate"
453
454	! yrnew - indicates the year associated with "ndate"
455	! monew - indicates the month associated with "ndate"
456	! dynew - indicates the day associated with "ndate"
457	! hrnew - indicates the hour associated with "ndate"
458	! minew - indicates the minute associated with "ndate"
459	! scnew - indicates the second associated with "ndate"
460
461	! mday - a list assigning the number of days in each month
462
463	! i - loop counter
464	! nday - the integer number of days represented by "idt"
465	! nhour - the integer number of hours in "idt" after taking out
466	! all the whole days
467	! nmin - the integer number of minutes in "idt" after taking out
468	! all the whole days and whole hours.
469	! nsec - the integer number of minutes in "idt" after taking out
470	! all the whole days, whole hours, and whole minutes.
471
472	INTEGER :: nlen, olen
473	INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
474	INTEGER :: yrold, moold, dyold, hrold, miold, scold, frold
475	INTEGER :: mday(12), nday, nhour, nmin, nsec, nfrac, i, ifrc
476	LOGICAL :: opass
477	CHARACTER (LEN=10) :: hfrc
478	CHARACTER (LEN=1) :: sp
479	! INTEGER, EXTERNAL :: nfeb ! in the same module now
480
481	! Assign the number of days in a months
482
483	mday( 1) = 31
484	mday( 2) = 28
485	mday( 3) = 31
486	mday( 4) = 30
487	mday( 5) = 31
488	mday( 6) = 30
489	mday( 7) = 31
490	mday( 8) = 31
491	mday( 9) = 30
492	mday(10) = 31
493	mday(11) = 30
494	mday(12) = 31
495
496	! Break down old hdate into parts
497
498	hrold = 0
499	miold = 0
500	scold = 0
501	frold = 0
502	olen = LEN(odate)
503	IF (olen.GE.11) THEN
504	sp = odate(11:11)
505	else
506	sp = ' '
507	END IF
508
509	! Use internal READ statements to convert the CHARACTER string
510	! date into INTEGER components.
511
512	READ(odate(1:4), '(I4)') yrold
513	#ifdef PLANET
514	READ(odate(6:10), '(I5)') dyold
515	moold=0.
516	#else
517	READ(odate(6:7), '(I2)') moold
518	READ(odate(9:10), '(I2)') dyold
519	#endif
520	IF (olen.GE.13) THEN
521	READ(odate(12:13),'(I2)') hrold
522	IF (olen.GE.16) THEN
523	READ(odate(15:16),'(I2)') miold
524	IF (olen.GE.19) THEN
525	READ(odate(18:19),'(I2)') scold
526	IF (olen.GT.20) THEN
527	READ(odate(21:olen),'(I2)') frold
528	END IF
529	END IF
530	END IF
531	END IF
532
533	! Set the number of days in February for that year.
534
535	mday(2) = nfeb(yrold)
536
537	! Check that ODATE makes sense.
538
539	opass = .TRUE.
540
541	#ifdef PLANET
542	! Check that the day of ODATE makes sense.
543	IF ((dyold.GT.PLANET_YEAR).or.(dyold.LT.1)) THEN
544	WRITE(,) 'GETH_NEWDATE: Day of ODATE = ', dyold
545	opass = .FALSE.
546	END IF
547	#else
548	! Check that the month of ODATE makes sense.
549
550	IF ((moold.GT.12).or.(moold.LT.1)) THEN
551	WRITE(,) 'GETH_NEWDATE: Month of ODATE = ', moold
552	opass = .FALSE.
553	END IF
554
555	! Check that the day of ODATE makes sense.
556
557	IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN
558	WRITE(,) 'GETH_NEWDATE: Day of ODATE = ', dyold
559	opass = .FALSE.
560	END IF
561	#endif
562	! Check that the hour of ODATE makes sense.
563
564	IF ((hrold.GT.23).or.(hrold.LT.0)) THEN
565	WRITE(,) 'GETH_NEWDATE: Hour of ODATE = ', hrold
566	opass = .FALSE.
567	END IF
568
569	! Check that the minute of ODATE makes sense.
570
571	IF ((miold.GT.59).or.(miold.LT.0)) THEN
572	WRITE(,) 'GETH_NEWDATE: Minute of ODATE = ', miold
573	opass = .FALSE.
574	END IF
575
576	! Check that the second of ODATE makes sense.
577
578	IF ((scold.GT.59).or.(scold.LT.0)) THEN
579	WRITE(,) 'GETH_NEWDATE: Second of ODATE = ', scold
580	opass = .FALSE.
581	END IF
582
583	! Check that the fractional part of ODATE makes sense.
584
585
586	IF (.not.opass) THEN
587	WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Bad ODATE: ', odate(1:olen), olen
588	CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
589	END IF
590
591	! Date Checks are completed. Continue.
592
593
594	! Compute the number of days, hours, minutes, and seconds in idt
595
596	IF (olen.GT.20) THEN !idt should be in fractions of seconds
597	ifrc = olen-20
598	ifrc = 10**ifrc
599	nday = ABS(idt)/(86400*ifrc)
600	nhour = MOD(ABS(idt),86400ifrc)/(3600ifrc)
601	nmin = MOD(ABS(idt),3600ifrc)/(60ifrc)
602	nsec = MOD(ABS(idt),60*ifrc)/(ifrc)
603	nfrac = MOD(ABS(idt), ifrc)
604	ELSE IF (olen.eq.19) THEN !idt should be in seconds
605	ifrc = 1
606	nday = ABS(idt)/86400 ! Integer number of days in delta-time
607	nhour = MOD(ABS(idt),86400)/3600
608	nmin = MOD(ABS(idt),3600)/60
609	nsec = MOD(ABS(idt),60)
610	nfrac = 0
611	ELSE IF (olen.eq.16) THEN !idt should be in minutes
612	ifrc = 1
613	nday = ABS(idt)/1440 ! Integer number of days in delta-time
614	nhour = MOD(ABS(idt),1440)/60
615	nmin = MOD(ABS(idt),60)
616	nsec = 0
617	nfrac = 0
618	ELSE IF (olen.eq.13) THEN !idt should be in hours
619	ifrc = 1
620	nday = ABS(idt)/24 ! Integer number of days in delta-time
621	nhour = MOD(ABS(idt),24)
622	nmin = 0
623	nsec = 0
624	nfrac = 0
625	ELSE IF (olen.eq.10) THEN !idt should be in days
626	ifrc = 1
627	nday = ABS(idt)/24 ! Integer number of days in delta-time
628	nhour = 0
629	nmin = 0
630	nsec = 0
631	nfrac = 0
632	ELSE
633	WRITE( wrf_err_message , * ) 'module_date_time: GETH_NEWDATE: Strange length for ODATE: ',olen
634	CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
635	END IF
636
637	IF (idt.GE.0) THEN
638
639	frnew = frold + nfrac
640	IF (frnew.GE.ifrc) THEN
641	frnew = frnew - ifrc
642	nsec = nsec + 1
643	END IF
644
645	scnew = scold + nsec
646	IF (scnew .GE. 60) THEN
647	scnew = scnew - 60
648	nmin = nmin + 1
649	END IF
650
651	minew = miold + nmin
652	IF (minew .GE. 60) THEN
653	minew = minew - 60
654	nhour = nhour + 1
655	END IF
656
657	hrnew = hrold + nhour
658	IF (hrnew .GE. 24) THEN
659	hrnew = hrnew - 24
660	nday = nday + 1
661	END IF
662
663	dynew = dyold
664	monew = moold
665	yrnew = yrold
666	DO i = 1, nday
667	dynew = dynew + 1
668	#ifdef PLANET
669	IF (dynew .GT. PLANET_YEAR) THEN
670	dynew = dynew - PLANET_YEAR
671	yrnew = yrnew + 1
672	END IF
673	#else
674	IF (dynew.GT.mday(monew)) THEN
675	dynew = dynew - mday(monew)
676	monew = monew + 1
677	IF (monew .GT. 12) THEN
678	monew = 1
679	yrnew = yrnew + 1
680	! If the year changes, recompute the number of days in February
681	mday(2) = nfeb(yrnew)
682	END IF
683	END IF
684	#endif
685	END DO
686
687	ELSE IF (idt.LT.0) THEN
688
689	frnew = frold - nfrac
690	IF (frnew .LT. 0) THEN
691	frnew = frnew + ifrc
692	nsec = nsec - 1
693	END IF
694
695	scnew = scold - nsec
696	IF (scnew .LT. 00) THEN
697	scnew = scnew + 60
698	nmin = nmin + 1
699	END IF
700
701	minew = miold - nmin
702	IF (minew .LT. 00) THEN
703	minew = minew + 60
704	nhour = nhour + 1
705	END IF
706
707	hrnew = hrold - nhour
708	IF (hrnew .LT. 00) THEN
709	hrnew = hrnew + 24
710	nday = nday + 1
711	END IF
712
713	dynew = dyold
714	monew = moold
715	yrnew = yrold
716	DO i = 1, nday
717	dynew = dynew - 1
718	#ifdef PLANET
719	IF (dynew.eq.0) THEN
720	dynew = PLANET_YEAR
721	yrnew = yrnew - 1
722	END IF
723	#else
724	IF (dynew.eq.0) THEN
725	monew = monew - 1
726	IF (monew.eq.0) THEN
727	monew = 12
728	yrnew = yrnew - 1
729	! If the year changes, recompute the number of days in February
730	mday(2) = nfeb(yrnew)
731	END IF
732	dynew = mday(monew)
733	END IF
734	#endif
735	END DO
736	END IF
737
738	! Now construct the new mdate
739
740	nlen = LEN(ndate)
741
742	#ifdef PLANET
743	IF (nlen.GT.20) THEN
744	WRITE(ndate(1:19),19) yrnew, dynew, hrnew, minew, scnew
745	WRITE(hfrc,'(I10)') frnew+1000000000
746	ndate = ndate(1:19)//'.'//hfrc(31-nlen:10)
747
748	ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN
749	WRITE(ndate(1:19),19) yrnew, dynew, hrnew, minew, scnew
750	19 format(I4.4,'-',I5.5,'_',I2.2,':',I2.2,':',I2.2)
751	IF (nlen.eq.20) ndate = ndate(1:19)//'.'
752
753	ELSE IF (nlen.eq.16) THEN
754	WRITE(ndate,16) yrnew, dynew, hrnew, minew
755	16 format(I4.4,'-',I5.5,'_',I2.2,':',I2.2)
756
757	ELSE IF (nlen.eq.13) THEN
758	WRITE(ndate,13) yrnew, dynew, hrnew
759	13 format(I4.4,'-',I5.5,'_',I2.2)
760
761	ELSE IF (nlen.eq.10) THEN
762	WRITE(ndate,10) yrnew, dynew
763	10 format(I4.4,'-',I5.5)
764
765	END IF
766
767	IF (olen.GE.11) ndate(11:11) = sp
768	#else
769	IF (nlen.GT.20) THEN
770	WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew
771	WRITE(hfrc,'(I10)') frnew+1000000000
772	ndate = ndate(1:19)//'.'//hfrc(31-nlen:10)
773
774	ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN
775	WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew
776	19 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)
777	IF (nlen.eq.20) ndate = ndate(1:19)//'.'
778
779	ELSE IF (nlen.eq.16) THEN
780	WRITE(ndate,16) yrnew, monew, dynew, hrnew, minew
781	16 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2)
782
783	ELSE IF (nlen.eq.13) THEN
784	WRITE(ndate,13) yrnew, monew, dynew, hrnew
785	13 format(I4,'-',I2.2,'-',I2.2,'_',I2.2)
786
787	ELSE IF (nlen.eq.10) THEN
788	WRITE(ndate,10) yrnew, monew, dynew
789	10 format(I4,'-',I2.2,'-',I2.2)
790
791	END IF
792
793	IF (olen.GE.11) ndate(11:11) = sp
794	#endif
795	END SUBROUTINE geth_newdate
796
797	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
798
799	FUNCTION nfeb ( year ) RESULT (num_days)
800
801	! Compute the number of days in February for the given year
802
803	IMPLICIT NONE
804
805	INTEGER :: year
806	INTEGER :: num_days
807
808	num_days = 28 ! By default, February has 28 days ...
809	IF (MOD(year,4).eq.0) THEN
810	num_days = 29 ! But every four years, it has 29 days ...
811	IF (MOD(year,100).eq.0) THEN
812	num_days = 28 ! Except every 100 years, when it has 28 days ...
813	IF (MOD(year,400).eq.0) THEN
814	num_days = 29 ! Except every 400 years, when it has 29 days.
815	END IF
816	END IF
817	END IF
818
819	END FUNCTION nfeb
820
821	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
822	SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , second , ten_thousandth)
823
824	IMPLICIT NONE
825
826	! Input data.
827
828	CHARACTER(LEN=24) , INTENT(IN) :: date
829
830	! Output data.
831
832	INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second , ten_thousandth
833
834	READ(date,FMT='( I4)') century_year
835	#ifdef PLANET
836	month = 0
837	READ(date,FMT='( 5X,I5)') day
838	#else
839	READ(date,FMT='( 5X,I2)') month
840	READ(date,FMT='( 8X,I2)') day
841	#endif
842	READ(date,FMT='(11X,I2)') hour
843	READ(date,FMT='(14X,I2)') minute
844	READ(date,FMT='(17X,I2)') second
845	READ(date,FMT='(20X,I4)') ten_thousandth
846
847	END SUBROUTINE split_date_char
848
849	SUBROUTINE init_module_date_time
850	END SUBROUTINE init_module_date_time
851
852	END MODULE module_date_time
853
854
855	! TBH: NOTE:
856	! TBH: Linkers whine if these routines are placed inside the module. Not
857	! TBH: sure if these should live here or inside an external package. They
858	! TBH: have dependencies both on WRF (for the format of the WRF date-time
859	! TBH: strings) and on the time manager. Currently, the format of the WRF
860	! TBH: date-time strings is a slight variant on ISO 8601 (ISO is
861	! TBH: "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss"). If we
862	! TBH: change the WRF format to match the standard, then we remove the
863	! TBH: WRF dependence...
864
865	! Converts WRF date-time string into an WRFU_Time object.
866	! The format of the WRF date-time strings is a slight variant on ISO 8601:
867	! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss".
868	SUBROUTINE wrf_atotime ( str, time )
869	USE module_utility
870	CHARACTER (LEN=*), INTENT(INOUT) :: str
871	TYPE(WRFU_Time), INTENT(OUT) :: time
872	INTEGER yr, mm, dd, h, m, s, ms
873	INTEGER rc
874	IF ( LEN( str ) .GE. 20 ) THEN
875	IF ( str(20:20) .EQ. '.' ) THEN
876	#ifdef PLANET
877	READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2,1x,I4.4)') yr,dd,h,m,s,ms
878	mm = 1
879	#else
880	READ(str,34) yr,mm,dd,h,m,s,ms
881	#endif
882	! last four digits are ten-thousandths of a sec, convert to ms
883	ms=nint(real(ms)/10)
884	ELSE
885	#ifdef PLANET
886	READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2)') yr,dd,h,m,s
887	mm = 1
888	#else
889	READ(str,33) yr,mm,dd,h,m,s
890	#endif
891	ms = 0
892	ENDIF
893	ELSE
894	#ifdef PLANET
895	READ(str,'(I4.4,1x,I5.5,1x,I2.2,1x,I2.2,1x,I2.2)') yr,dd,h,m,s
896	mm = 1
897	#else
898	READ(str,33) yr,mm,dd,h,m,s
899	#endif
900	ms = 0
901	ENDIF
902	CALL WRFU_TimeSet( time, YY=yr, MM=mm, DD=dd, H=h, M=m, S=s, MS=ms, rc=rc )
903	CALL wrf_check_error( WRFU_SUCCESS, rc, &
904	'WRFU_TimeSet() in wrf_atotime() FAILED', &
905	__FILE__ , &
906	__LINE__ )
907	33 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2)
908	34 FORMAT (I4.4,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I2.2,1x,I4.4)
909	RETURN
910	END SUBROUTINE wrf_atotime
911
912
913
914	! Converts an WRFU_Time object into a WRF date-time string.
915	! The format of the WRF date-time strings is a slight variant on ISO 8601:
916	! ISO is "YYYY-MM-DDThh:mm:ss" while WRF is "YYYY-MM-DD_hh:mm:ss".
917	SUBROUTINE wrf_timetoa ( time, str )
918	USE module_utility
919	TYPE(WRFU_Time), INTENT(INOUT) :: time
920	CHARACTER (LEN=*), INTENT(OUT) :: str
921	INTEGER strlen, rc
922	CHARACTER (LEN=256) :: mess, tmpstr
923	! Assertion
924	IF ( LEN(str) < 19 ) THEN
925	CALL wrf_error_fatal( 'wrf_timetoa: str is too short' )
926	ENDIF
927	tmpstr = ''
928	CALL WRFU_TimeGet( time, timeString=tmpstr, rc=rc )
929	CALL wrf_check_error( WRFU_SUCCESS, rc, &
930	'WRFU_TimeGet() in wrf_timetoa() FAILED', &
931	__FILE__ , &
932	__LINE__ )
933	! change ISO 8601 'T' to WRF '_' and hack off fraction if str is not
934	! big enough to hold it
935	strlen = MIN( LEN(str), LEN_TRIM(tmpstr) )
936	str = ''
937	str(1:strlen) = tmpstr(1:strlen)
938	str(11:11) = '_'
939	WRITE (mess,*) 'DEBUG wrf_timetoa(): returning with str = [',TRIM(str),']'
940	CALL wrf_debug ( 150 , TRIM(mess) )
941	RETURN
942	END SUBROUTINE wrf_timetoa
943
944
945
946	! Converts an WRFU_TimeInterval object into a time-interval string.
947	SUBROUTINE wrf_timeinttoa ( timeinterval, str )
948	USE module_utility
949	TYPE(WRFU_TimeInterval), INTENT(INOUT) :: timeinterval
950	CHARACTER (LEN=*), INTENT(OUT) :: str
951	INTEGER rc
952	CHARACTER (LEN=256) :: mess
953	CALL WRFU_TimeIntervalGet( timeinterval, timeString=str, rc=rc )
954	CALL wrf_check_error( WRFU_SUCCESS, rc, &
955	'WRFU_TimeIntervalGet() in wrf_timeinttoa() FAILED', &
956	__FILE__ , &
957	__LINE__ )
958	WRITE (mess,*) 'DEBUG wrf_timeinttoa(): returning with str = [',TRIM(str),']'
959	CALL wrf_debug ( 150 , TRIM(mess) )
960	RETURN
961	END SUBROUTINE wrf_timeinttoa
962
963
964
965	! Debug routine to print key clock information.
966	! Every printed line begins with pre_str.
967	SUBROUTINE wrf_clockprint ( level, clock, pre_str )
968	USE module_utility
969	INTEGER, INTENT( IN) :: level
970	TYPE(WRFU_Clock), INTENT( IN) :: clock
971	CHARACTER (LEN=*), INTENT( IN) :: pre_str
972	INTEGER rc
973	INTEGER :: debug_level
974	TYPE(WRFU_Time) :: currTime, startTime, stopTime
975	TYPE(WRFU_TimeInterval) :: timeStep
976	CHARACTER (LEN=64) :: currTime_str, startTime_str, stopTime_str
977	CHARACTER (LEN=64) :: timeStep_str
978	CHARACTER (LEN=256) :: mess
979	CALL get_wrf_debug_level( debug_level )
980	IF ( level .LE. debug_level ) THEN
981	CALL WRFU_ClockGet( clock, CurrTime=currTime, StartTime=startTime, &
982	StopTime=stopTime, TimeStep=timeStep, rc=rc )
983	CALL wrf_check_error( WRFU_SUCCESS, rc, &
984	'wrf_clockprint: WRFU_ClockGet() FAILED', &
985	__FILE__ , &
986	__LINE__ )
987	CALL wrf_timetoa( currTime, currTime_str )
988	CALL wrf_timetoa( startTime, startTime_str )
989	CALL wrf_timetoa( stopTime, stopTime_str )
990	CALL wrf_timeinttoa( timeStep, timeStep_str )
991	WRITE (mess,*) TRIM(pre_str),' clock start time = ',TRIM(startTime_str)
992	CALL wrf_message(TRIM(mess))
993	WRITE (mess,*) TRIM(pre_str),' clock current time = ',TRIM(currTime_str)
994	CALL wrf_message(TRIM(mess))
995	WRITE (mess,*) TRIM(pre_str),' clock stop time = ',TRIM(stopTime_str)
996	CALL wrf_message(TRIM(mess))
997	WRITE (mess,*) TRIM(pre_str),' clock time step = ',TRIM(timeStep_str)
998	CALL wrf_message(TRIM(mess))
999	ENDIF
1000	RETURN
1001	END SUBROUTINE wrf_clockprint
1002

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

Download in other formats:

Original Format