Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

Meat.F90 @ 3709

Last change on this file since 3709 was 11, checked in by aslmd, 15 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 26.2 KB

Line
1	#include <ESMF_TimeMgr.inc>
2
3	! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match.
4	! Also, enforce consistency.
5	! YR and MM fields are ignored.
6	SUBROUTINE normalize_basetime( basetime )
7	USE esmf_basemod
8	USE esmf_basetimemod
9	IMPLICIT NONE
10	TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime
11	!PRINT *,'DEBUG: BEGIN normalize_basetime()'
12	! Consistency check...
13	IF ( basetime%Sd < 0 ) THEN
14	CALL wrf_error_fatal( &
15	'normalize_basetime: denominator of seconds cannot be negative' )
16	ENDIF
17	IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN
18	CALL wrf_error_fatal( &
19	'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' )
20	ENDIF
21	! factor so abs(Sn) < Sd
22	IF ( basetime%Sd > 0 ) THEN
23	IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN
24	!PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
25	basetime%S = basetime%S + ( basetime%Sn / basetime%Sd )
26	basetime%Sn = mod( basetime%Sn, basetime%Sd )
27	!PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
28	ENDIF
29	! change sign of Sn if it does not match S
30	IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN
31	!PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
32	basetime%S = basetime%S - 1_ESMF_KIND_I8
33	basetime%Sn = basetime%Sn + basetime%Sd
34	!PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
35	ENDIF
36	IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN
37	!PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
38	basetime%S = basetime%S + 1_ESMF_KIND_I8
39	basetime%Sn = basetime%Sn - basetime%Sd
40	!PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
41	ENDIF
42	ENDIF
43	!PRINT *,'DEBUG: END normalize_basetime()'
44	END SUBROUTINE normalize_basetime
45
46
47
48	! A normalized time has time%basetime >= 0, time%basetime less than the current
49	! year expressed as a timeInterval, and time%YR can take any value
50	SUBROUTINE normalize_time( time )
51	USE esmf_basemod
52	USE esmf_basetimemod
53	USE esmf_timemod
54	IMPLICIT NONE
55	TYPE(ESMF_Time), INTENT(INOUT) :: time
56	INTEGER(ESMF_KIND_I8) :: nsecondsinyear
57	! locals
58	TYPE(ESMF_BaseTime) :: cmptime, zerotime
59	INTEGER :: rc
60	LOGICAL :: done
61
62	! first, normalize basetime
63	! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
64	CALL normalize_basetime( time%basetime )
65
66	!$$$ add tests for these edge cases
67
68	! next, underflow negative seconds into YEARS
69	! time%basetime must end up non-negative
70	!$$$ push this down into ESMF_BaseTime constructor
71	zerotime%S = 0
72	zerotime%Sn = 0
73	zerotime%Sd = 0
74	DO WHILE ( time%basetime < zerotime )
75	time%YR = time%YR - 1
76	!$$$ push this down into ESMF_BaseTime constructor
77	cmptime%S = nsecondsinyear( time%YR )
78	cmptime%Sn = 0
79	cmptime%Sd = 0
80	time%basetime = time%basetime + cmptime
81	ENDDO
82
83	! next, overflow seconds into YEARS
84	done = .FALSE.
85	DO WHILE ( .NOT. done )
86	!$$$ push this down into ESMF_BaseTime constructor
87	cmptime%S = nsecondsinyear( time%YR )
88	cmptime%Sn = 0
89	cmptime%Sd = 0
90	IF ( time%basetime >= cmptime ) THEN
91	time%basetime = time%basetime - cmptime
92	time%YR = time%YR + 1
93	ELSE
94	done = .TRUE.
95	ENDIF
96	ENDDO
97	END SUBROUTINE normalize_time
98
99
100
101	SUBROUTINE normalize_timeint( timeInt )
102	USE esmf_basetimemod
103	USE esmf_timeintervalmod
104	IMPLICIT NONE
105	TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt
106
107	! normalize basetime
108	! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
109	! YR and MM are ignored
110	CALL normalize_basetime( timeInt%basetime )
111	END SUBROUTINE normalize_timeint
112
113
114
115
116	FUNCTION signnormtimeint ( timeInt )
117	! Compute the sign of a time interval.
118	! YR and MM fields are IGNORED.
119	! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs.
120	USE esmf_basemod
121	USE esmf_basetimemod
122	USE esmf_timeintervalmod
123	IMPLICIT NONE
124	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
125	INTEGER :: signnormtimeint
126	LOGICAL :: positive, negative
127
128	positive = .FALSE.
129	negative = .FALSE.
130	signnormtimeint = 0
131	! Note that Sd is required to be non-negative. This is enforced in
132	! normalize_timeint().
133	! Note that Sn is required to be zero when Sd is zero. This is enforced
134	! in normalize_timeint().
135	IF ( ( timeInt%basetime%S > 0 ) .OR. &
136	( timeInt%basetime%Sn > 0 ) ) THEN
137	positive = .TRUE.
138	ENDIF
139	IF ( ( timeInt%basetime%S < 0 ) .OR. &
140	( timeInt%basetime%Sn < 0 ) ) THEN
141	negative = .TRUE.
142	ENDIF
143	IF ( positive .AND. negative ) THEN
144	CALL wrf_error_fatal( &
145	'signnormtimeint: signs of fields cannot be mixed' )
146	ELSE IF ( positive ) THEN
147	signnormtimeint = 1
148	ELSE IF ( negative ) THEN
149	signnormtimeint = -1
150	ENDIF
151	END FUNCTION signnormtimeint
152
153
154	! Exits with error message if timeInt is not normalized.
155	SUBROUTINE timeintchecknormalized( timeInt, msgstr )
156	USE esmf_timeintervalmod
157	IMPLICIT NONE
158	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
159	CHARACTER(LEN=*), INTENT(IN) :: msgstr
160	! locals
161	CHARACTER(LEN=256) :: outstr
162	IF ( ( timeInt%YR /= 0 ) .OR. &
163	( timeInt%MM /= 0 ) ) THEN
164	outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr)
165	CALL wrf_error_fatal( outstr )
166	ENDIF
167	END SUBROUTINE timeintchecknormalized
168
169
170	! added from share/module_date_time in WRF.
171	FUNCTION nfeb ( year ) RESULT (num_days)
172	! Compute the number of days in February for the given year
173	IMPLICIT NONE
174	INTEGER :: year
175	INTEGER :: num_days
176	!#ifdef NO_LEAP_CALENDAR
177	! num_days = 28 ! By default, February has 28 days ...
178	!#else
179	! num_days = 28 ! By default, February has 28 days ...
180	! IF (MOD(year,4).eq.0) THEN
181	! num_days = 29 ! But every four years, it has 29 days ...
182	! IF (MOD(year,100).eq.0) THEN
183	! num_days = 28 ! Except every 100 years, when it has 28 days ...
184	! IF (MOD(year,400).eq.0) THEN
185	! num_days = 29 ! Except every 400 years, when it has 29 days.
186	! END IF
187	! END IF
188	! END IF
189	!#endif
190	num_days = 1
191	! just to keep continuity
192	END FUNCTION nfeb
193
194
195
196	FUNCTION ndaysinyear ( year ) RESULT (num_diy)
197	! Compute the number of days in the given year
198	IMPLICIT NONE
199	INTEGER, INTENT(IN) :: year
200	INTEGER :: num_diy
201	! INTEGER :: nfeb
202	! IF ( nfeb( year ) .EQ. 29 ) THEN
203	! num_diy = 366
204	! ELSE
205	! num_diy = 365
206	! ENDIF
207	num_diy = 669
208	END FUNCTION ndaysinyear
209
210
211
212	FUNCTION nsecondsinyear ( year ) RESULT (numseconds)
213	! Compute the number of seconds in the given year
214	USE esmf_basemod
215	IMPLICIT NONE
216	INTEGER, INTENT(IN) :: year
217	INTEGER(ESMF_KIND_I8) :: numseconds
218	INTEGER :: ndaysinyear
219	numseconds = SECONDS_PER_DAY * INT( ndaysinyear(year) , ESMF_KIND_I8 )
220	END FUNCTION nsecondsinyear
221
222
223
224	SUBROUTINE initdaym
225	USE esmf_basemod
226	USE esmf_basetimemod
227	USE ESMF_CalendarMod
228	IMPLICIT NONE
229	INTEGER i,j,m
230	m = 1
231	mdaycum(0) = 0
232	!$$$ push this down into ESMF_BaseTime constructor
233	monthbdys(0)%S = 0
234	monthbdys(0)%Sn = 0
235	monthbdys(0)%Sd = 0
236	DO i = 1,MONTHS_PER_YEAR
237	DO j = 1,mday(i)
238	daym(m) = i
239	m = m + 1
240	ENDDO
241	mdaycum(i) = mdaycum(i-1) + mday(i)
242	!$$$ push this down into ESMF_BaseTime constructor
243	monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 )
244	monthbdys(i)%Sn = 0
245	monthbdys(i)%Sd = 0
246	ENDDO
247	m = 1
248	mdayleapcum(0) = 0
249	!$$$ push this down into ESMF_BaseTime constructor
250	monthbdysleap(0)%S = 0
251	monthbdysleap(0)%Sn = 0
252	monthbdysleap(0)%Sd = 0
253	DO i = 1,MONTHS_PER_YEAR
254	DO j = 1,mdayleap(i)
255	daymleap(m) = i
256	m = m + 1
257	ENDDO
258	mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i)
259	!$$$ push this down into ESMF_BaseTime constructor
260	monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 )
261	monthbdysleap(i)%Sn = 0
262	monthbdysleap(i)%Sd = 0
263	ENDDO
264	END SUBROUTINE initdaym
265
266
267	!!$$$ useful, but not used at the moment...
268	!SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear)
269	! use ESMF_CalendarMod
270	!IMPLICIT NONE
271	! INTEGER, INTENT(IN) :: YR,MM,DD ! DD is day of month
272	! INTEGER, INTENT(OUT) :: dayinyear
273	! INTEGER i
274	! integer nfeb
275	!
276	! dayinyear = 0
277	! DO i = 1,MM-1
278	! if (i.eq.2) then
279	! dayinyear = dayinyear + nfeb(YR)
280	! else
281	! dayinyear = dayinyear + mday(i)
282	! endif
283	! ENDDO
284	! dayinyear = dayinyear + DD
285	!END SUBROUTINE compute_dayinyear
286
287
288
289	SUBROUTINE timegetmonth( time, MM )
290	USE esmf_basemod
291	USE esmf_basetimemod
292	USE esmf_timemod
293	USE esmf_calendarmod
294	IMPLICIT NONE
295	TYPE(ESMF_Time), INTENT(IN) :: time
296	INTEGER, INTENT(OUT) :: MM
297	! locals
298	INTEGER :: nfeb
299	INTEGER :: i
300	TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
301	! IF ( nfeb(time%YR) == 29 ) THEN
302	! MMbdys => monthbdysleap
303	! ELSE
304	MMbdys => monthbdys
305	! ENDIF
306	MM = -1
307	DO i = 1,MONTHS_PER_YEAR
308	IF ( ( time%basetime >= MMbdys(i-1) ) .AND. ( time%basetime < MMbdys(i) ) ) THEN
309	MM = i
310	EXIT
311	ENDIF
312	ENDDO
313	IF ( MM == -1 ) THEN
314	CALL wrf_error_fatal( 'timegetmonth: could not extract month of year from time' )
315	ENDIF
316	END SUBROUTINE timegetmonth
317
318
319	!$$$ may need to change dependencies in Makefile...
320
321	SUBROUTINE timegetdayofmonth( time, DD )
322	USE esmf_basemod
323	USE esmf_basetimemod
324	USE esmf_timemod
325	USE esmf_calendarmod
326	IMPLICIT NONE
327	TYPE(ESMF_Time), INTENT(IN) :: time
328	INTEGER, INTENT(OUT) :: DD
329	! locals
330	INTEGER :: nfeb
331	INTEGER :: MM
332	TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
333	TYPE(ESMF_BaseTime) :: tmpbasetime
334	!!$$$ fix this so init just points MMbdys to the one we want for this calendar?
335	! IF ( nfeb(time%YR) == 29 ) THEN
336	MMbdys => monthbdysleap
337	! ELSE
338	! MMbdys => monthbdys
339	! ENDIF
340	CALL timegetmonth( time, MM )
341	tmpbasetime = time%basetime - MMbdys(MM-1)
342	DD = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1
343	END SUBROUTINE timegetdayofmonth
344
345
346	! Increment Time by number of seconds between start of year and start
347	! of month MM.
348	! 1 <= MM <= 12
349	! Time is NOT normalized.
350	SUBROUTINE timeaddmonths( time, MM, ierr )
351	USE esmf_basemod
352	USE esmf_basetimemod
353	USE esmf_timemod
354	USE esmf_calendarmod
355	IMPLICIT NONE
356	TYPE(ESMF_Time), INTENT(INOUT) :: time
357	INTEGER, INTENT(IN) :: MM
358	INTEGER, INTENT(OUT) :: ierr
359	! locals
360	INTEGER :: nfeb
361	TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
362	ierr = ESMF_SUCCESS
363	! PRINT *,'DEBUG: BEGIN timeaddmonths()'
364	IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN
365	CALL wrf_message( 'ERROR timeaddmonths(): MM out of range' )
366	ierr = ESMF_FAILURE
367	ENDIF
368	! PRINT *,'DEBUG: timeaddmonths(): MM = ',MM
369	!$$$ fix this so init just points MMbdys to the one we want for this calendar?
370	! PRINT *,'DEBUG: timeaddmonths(): time%YR = ',time%YR
371	! PRINT *,'DEBUG: timeaddmonths(): time%basetime%S = ',time%basetime%S
372	! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sn = ',time%basetime%Sn
373	! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sd = ',time%basetime%Sd
374	! IF ( nfeb(time%YR) == 29 ) THEN
375	!! PRINT *,'DEBUG: timeaddmonths(): leap year'
376	! MMbdys => monthbdysleap
377	! ELSE
378	! PRINT *,'DEBUG: timeaddmonths(): not leap year'
379	MMbdys => monthbdys
380	! ENDIF
381	! PRINT *,'DEBUG: timeaddmonths(): done pointing to MMbdys'
382	! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%S = ',MMbdys(MM-1)%S
383	! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sn = ',MMbdys(MM-1)%Sn
384	! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sd = ',MMbdys(MM-1)%Sd
385	!$$$ dumps core here...
386	time%basetime = time%basetime + MMbdys(MM-1)
387	! PRINT *,'DEBUG: END timeaddmonths()'
388	END SUBROUTINE timeaddmonths
389
390
391	! Increment Time by number of seconds in the current month.
392	! Time is NOT normalized.
393	SUBROUTINE timeincmonth( time )
394	USE esmf_basemod
395	USE esmf_basetimemod
396	USE esmf_timemod
397	USE esmf_calendarmod
398	IMPLICIT NONE
399	TYPE(ESMF_Time), INTENT(INOUT) :: time
400	! locals
401	INTEGER :: nfeb
402	INTEGER :: MM
403	CALL timegetmonth( time, MM )
404	! IF ( nfeb(time%YR) == 29 ) THEN
405	! time%basetime%S = time%basetime%S + &
406	! ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
407	! ELSE
408	time%basetime%S = time%basetime%S + &
409	( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
410	! ENDIF
411	END SUBROUTINE timeincmonth
412
413
414
415	! Decrement Time by number of seconds in the previous month.
416	! Time is NOT normalized.
417	SUBROUTINE timedecmonth( time )
418	USE esmf_basemod
419	USE esmf_basetimemod
420	USE esmf_timemod
421	USE esmf_calendarmod
422	IMPLICIT NONE
423	TYPE(ESMF_Time), INTENT(INOUT) :: time
424	! locals
425	INTEGER :: nfeb
426	INTEGER :: MM
427	CALL timegetmonth( time, MM ) ! current month, 1-12
428	! find previous month
429	MM = MM - 1
430	IF ( MM == 0 ) THEN
431	! wrap around Jan -> Dec
432	MM = MONTHS_PER_YEAR
433	ENDIF
434	! IF ( nfeb(time%YR) == 29 ) THEN
435	! time%basetime%S = time%basetime%S - &
436	! ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
437	! ELSE
438	time%basetime%S = time%basetime%S - &
439	( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
440	! ENDIF
441	END SUBROUTINE timedecmonth
442
443
444
445	! spaceship operator for Times
446	SUBROUTINE timecmp(time1, time2, retval )
447	USE esmf_basemod
448	USE esmf_basetimemod
449	USE esmf_timemod
450	IMPLICIT NONE
451	INTEGER, INTENT(OUT) :: retval
452	!
453	! !ARGUMENTS:
454	TYPE(ESMF_Time), INTENT(IN) :: time1
455	TYPE(ESMF_Time), INTENT(IN) :: time2
456	IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF
457	IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF
458	CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, &
459	time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, &
460	retval )
461	END SUBROUTINE timecmp
462
463
464
465	! spaceship operator for TimeIntervals
466	SUBROUTINE timeintcmp(timeint1, timeint2, retval )
467	USE esmf_basemod
468	USE esmf_basetimemod
469	USE esmf_timeintervalmod
470	IMPLICIT NONE
471	INTEGER, INTENT(OUT) :: retval
472	!
473	! !ARGUMENTS:
474	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
475	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
476	CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' )
477	CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' )
478	CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, &
479	timeint1%basetime%Sd, &
480	timeint2%basetime%S, timeint2%basetime%Sn, &
481	timeint2%basetime%Sd, retval )
482	END SUBROUTINE timeintcmp
483
484
485
486	! spaceship operator for seconds + Sn/Sd
487	SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval )
488	USE esmf_basemod
489	IMPLICIT NONE
490	INTEGER, INTENT(OUT) :: retval
491	!
492	! !ARGUMENTS:
493	INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1
494	INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2
495	! local
496	INTEGER(ESMF_KIND_I8) :: lcd, n1, n2
497
498	n1 = Sn1
499	n2 = Sn2
500	if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then
501	CALL compute_lcd( Sd1, Sd2, lcd )
502	if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 )
503	if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 )
504	endif
505
506	if ( S1 .GT. S2 ) retval = 1
507	if ( S1 .LT. S2 ) retval = -1
508	IF ( S1 .EQ. S2 ) THEN
509	IF (n1 .GT. n2) retval = 1
510	IF (n1 .LT. n2) retval = -1
511	IF (n1 .EQ. n2) retval = 0
512	ENDIF
513	END SUBROUTINE seccmp
514
515
516	SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag)
517	USE esmf_alarmmod
518	USE esmf_basemod
519	USE esmf_basetimemod
520	USE esmf_calendarmod
521	USE esmf_clockmod
522	USE esmf_fractionmod
523	USE esmf_timeintervalmod
524	USE esmf_timemod
525	IMPLICIT NONE
526	logical, intent(OUT) :: outflag
527	type(ESMF_Time), intent(in) :: time1
528	type(ESMF_Time), intent(in) :: time2
529	integer res
530	CALL timecmp(time1,time2,res)
531	outflag = (res .EQ. 0)
532	END SUBROUTINE c_esmc_basetimeeq
533	SUBROUTINE c_esmc_basetimege(time1, time2, outflag)
534	USE esmf_alarmmod
535	USE esmf_basemod
536	USE esmf_basetimemod
537	USE esmf_calendarmod
538	USE esmf_clockmod
539	USE esmf_fractionmod
540	USE esmf_timeintervalmod
541	USE esmf_timemod
542	logical, intent(OUT) :: outflag
543	type(ESMF_Time), intent(in) :: time1
544	type(ESMF_Time), intent(in) :: time2
545	integer res
546	CALL timecmp(time1,time2,res)
547	outflag = (res .EQ. 1 .OR. res .EQ. 0)
548	END SUBROUTINE c_esmc_basetimege
549	SUBROUTINE c_esmc_basetimegt(time1, time2, outflag)
550	USE esmf_alarmmod
551	USE esmf_basemod
552	USE esmf_basetimemod
553	USE esmf_calendarmod
554	USE esmf_clockmod
555	USE esmf_fractionmod
556	USE esmf_timeintervalmod
557	USE esmf_timemod
558	IMPLICIT NONE
559	logical, intent(OUT) :: outflag
560	type(ESMF_Time), intent(in) :: time1
561	type(ESMF_Time), intent(in) :: time2
562	integer res
563	CALL timecmp(time1,time2,res)
564	outflag = (res .EQ. 1)
565	END SUBROUTINE c_esmc_basetimegt
566	SUBROUTINE c_esmc_basetimele(time1, time2, outflag)
567	USE esmf_alarmmod
568	USE esmf_basemod
569	USE esmf_basetimemod
570	USE esmf_calendarmod
571	USE esmf_clockmod
572	USE esmf_fractionmod
573	USE esmf_timeintervalmod
574	USE esmf_timemod
575	IMPLICIT NONE
576	logical, intent(OUT) :: outflag
577	type(ESMF_Time), intent(in) :: time1
578	type(ESMF_Time), intent(in) :: time2
579	integer res
580	CALL timecmp(time1,time2,res)
581	outflag = (res .EQ. -1 .OR. res .EQ. 0)
582	END SUBROUTINE c_esmc_basetimele
583	SUBROUTINE c_esmc_basetimelt(time1, time2, outflag)
584	USE esmf_alarmmod
585	USE esmf_basemod
586	USE esmf_basetimemod
587	USE esmf_calendarmod
588	USE esmf_clockmod
589	USE esmf_fractionmod
590	USE esmf_timeintervalmod
591	USE esmf_timemod
592	IMPLICIT NONE
593	logical, intent(OUT) :: outflag
594	type(ESMF_Time), intent(in) :: time1
595	type(ESMF_Time), intent(in) :: time2
596	integer res
597	CALL timecmp(time1,time2,res)
598	outflag = (res .EQ. -1)
599	END SUBROUTINE c_esmc_basetimelt
600	SUBROUTINE c_esmc_basetimene(time1, time2, outflag)
601	USE esmf_alarmmod
602	USE esmf_basemod
603	USE esmf_basetimemod
604	USE esmf_calendarmod
605	USE esmf_clockmod
606	USE esmf_fractionmod
607	USE esmf_timeintervalmod
608	USE esmf_timemod
609	IMPLICIT NONE
610	logical, intent(OUT) :: outflag
611	type(ESMF_Time), intent(in) :: time1
612	type(ESMF_Time), intent(in) :: time2
613	integer res
614	CALL timecmp(time1,time2,res)
615	outflag = (res .NE. 0)
616	END SUBROUTINE c_esmc_basetimene
617
618	SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag)
619	USE esmf_timeintervalmod
620	IMPLICIT NONE
621	LOGICAL, INTENT(OUT) :: outflag
622	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
623	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
624	INTEGER :: res
625	CALL timeintcmp(timeint1,timeint2,res)
626	outflag = (res .EQ. 0)
627	END SUBROUTINE c_esmc_basetimeinteq
628	SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag)
629	USE esmf_timeintervalmod
630	IMPLICIT NONE
631	LOGICAL, INTENT(OUT) :: outflag
632	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
633	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
634	INTEGER :: res
635	CALL timeintcmp(timeint1,timeint2,res)
636	outflag = (res .NE. 0)
637	END SUBROUTINE c_esmc_basetimeintne
638	SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag)
639	USE esmf_timeintervalmod
640	IMPLICIT NONE
641	LOGICAL, INTENT(OUT) :: outflag
642	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
643	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
644	INTEGER :: res
645	CALL timeintcmp(timeint1,timeint2,res)
646	outflag = (res .LT. 0)
647	END SUBROUTINE c_esmc_basetimeintlt
648	SUBROUTINE c_esmc_basetimeintgt(timeint1, timeint2, outflag)
649	USE esmf_timeintervalmod
650	IMPLICIT NONE
651	LOGICAL, INTENT(OUT) :: outflag
652	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
653	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
654	INTEGER :: res
655	CALL timeintcmp(timeint1,timeint2,res)
656	outflag = (res .GT. 0)
657	END SUBROUTINE c_esmc_basetimeintgt
658	SUBROUTINE c_esmc_basetimeintle(timeint1, timeint2, outflag)
659	USE esmf_timeintervalmod
660	IMPLICIT NONE
661	LOGICAL, INTENT(OUT) :: outflag
662	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
663	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
664	INTEGER :: res
665	CALL timeintcmp(timeint1,timeint2,res)
666	outflag = (res .LE. 0)
667	END SUBROUTINE c_esmc_basetimeintle
668	SUBROUTINE c_esmc_basetimeintge(timeint1, timeint2, outflag)
669	USE esmf_timeintervalmod
670	IMPLICIT NONE
671	LOGICAL, INTENT(OUT) :: outflag
672	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
673	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
674	INTEGER :: res
675	CALL timeintcmp(timeint1,timeint2,res)
676	outflag = (res .GE. 0)
677	END SUBROUTINE c_esmc_basetimeintge
678
679	SUBROUTINE compute_lcd( e1, e2, lcd )
680	USE esmf_basemod
681	IMPLICIT NONE
682	INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2
683	INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd
684	INTEGER, PARAMETER :: nprimes = 9
685	INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
686	INTEGER i
687	INTEGER(ESMF_KIND_I8) d1, d2, p
688
689	d1 = e1 ; d2 = e2
690	IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF
691	IF ( d1 .EQ. 0 ) d1 = d2
692	IF ( d2 .EQ. 0 ) d2 = d1
693	IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF
694	lcd = d1 * d2
695	DO i = 1, nprimes
696	p = primes(i)
697	DO WHILE (lcd/p .NE. 0 .AND. &
698	mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0)
699	lcd = lcd / p
700	END DO
701	ENDDO
702	END SUBROUTINE compute_lcd
703
704	SUBROUTINE simplify( ni, di, no, do )
705	USE esmf_basemod
706	IMPLICIT NONE
707	INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di
708	INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
709	INTEGER, PARAMETER :: nprimes = 9
710	INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
711	INTEGER(ESMF_KIND_I8) :: pr, d, n
712	INTEGER :: np
713	LOGICAL keepgoing
714	IF ( ni .EQ. 0 ) THEN
715	do = 1
716	no = 0
717	RETURN
718	ENDIF
719	IF ( mod( di , ni ) .EQ. 0 ) THEN
720	do = di / ni
721	no = 1
722	RETURN
723	ENDIF
724	d = di
725	n = ni
726	DO np = 1, nprimes
727	pr = primes(np)
728	keepgoing = .TRUE.
729	DO WHILE ( keepgoing )
730	keepgoing = .FALSE.
731	IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
732	d = d / pr
733	n = n / pr
734	keepgoing = .TRUE.
735	ENDIF
736	ENDDO
737	ENDDO
738	do = d
739	no = n
740	RETURN
741	END SUBROUTINE simplify
742
743
744	!$$$ this should be named "c_esmc_timesum" or something less misleading
745	SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
746	USE esmf_basemod
747	USE esmf_basetimemod
748	USE esmf_timeintervalmod
749	USE esmf_timemod
750	IMPLICIT NONE
751	TYPE(ESMF_Time), INTENT(IN) :: time1
752	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
753	TYPE(ESMF_Time), INTENT(INOUT) :: timeOut
754	! locals
755	INTEGER :: m
756	timeOut = time1
757	timeOut%basetime = timeOut%basetime + timeinterval%basetime
758	DO m = 1, abs(timeinterval%MM)
759	IF ( timeinterval%MM > 0 ) THEN
760	CALL timeincmonth( timeOut )
761	ELSE
762	CALL timedecmonth( timeOut )
763	ENDIF
764	ENDDO
765	timeOut%YR = timeOut%YR + timeinterval%YR
766	CALL normalize_time( timeOut )
767	END SUBROUTINE c_esmc_basetimesum
768
769
770	!$$$ this should be named "c_esmc_timedec" or something less misleading
771	SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut )
772	USE esmf_basemod
773	USE esmf_basetimemod
774	USE esmf_timeintervalmod
775	USE esmf_timemod
776	IMPLICIT NONE
777	TYPE(ESMF_Time), INTENT(IN) :: time1
778	TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
779	TYPE(ESMF_Time), INTENT(OUT) :: timeOut
780	! locals
781	TYPE (ESMF_TimeInterval) :: neginterval
782	neginterval = timeinterval
783	!$$$push this down into a unary negation operator on TimeInterval
784	neginterval%basetime%S = -neginterval%basetime%S
785	neginterval%basetime%Sn = -neginterval%basetime%Sn
786	neginterval%YR = -neginterval%YR
787	neginterval%MM = -neginterval%MM
788	timeOut = time1 + neginterval
789	END SUBROUTINE c_esmc_basetimedec
790
791
792	!$$$ this should be named "c_esmc_timediff" or something less misleading
793	SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut )
794	USE esmf_basemod
795	USE esmf_basetimemod
796	USE esmf_timeintervalmod
797	USE esmf_timemod
798	IMPLICIT NONE
799	TYPE(ESMF_Time), INTENT(IN) :: time1
800	TYPE(ESMF_Time), INTENT(IN) :: time2
801	TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut
802	! locals
803	INTEGER(ESMF_KIND_I8) :: nsecondsinyear
804	INTEGER :: yr
805	CALL ESMF_TimeIntervalSet( timeIntOut )
806	timeIntOut%basetime = time1%basetime - time2%basetime
807	! convert difference in years to basetime...
808	IF ( time1%YR > time2%YR ) THEN
809	DO yr = time2%YR, ( time1%YR - 1 )
810	timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr )
811	ENDDO
812	ELSE IF ( time2%YR > time1%YR ) THEN
813	DO yr = time1%YR, ( time2%YR - 1 )
814	timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr )
815	ENDDO
816	ENDIF
817	!$$$ add tests for multi-year differences
818	CALL normalize_timeint( timeIntOut )
819	END SUBROUTINE c_esmc_basetimediff
820
821
822	! some extra wrf stuff
823
824
825	! Convert fraction to string with leading sign.
826	! If fraction simplifies to a whole number or if
827	! denominator is zero, return empty string.
828	! INTEGER*8 interface.
829	SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
830	USE ESMF_basemod
831	IMPLICIT NONE
832	INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
833	INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
834	CHARACTER (LEN=*), INTENT(OUT) :: frac_str
835	IF ( denominator > 0 ) THEN
836	IF ( mod( numerator, denominator ) /= 0 ) THEN
837	IF ( numerator > 0 ) THEN
838	WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
839	ELSE ! numerator < 0
840	WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
841	ENDIF
842	ELSE ! includes numerator == 0 case
843	frac_str = ''
844	ENDIF
845	ELSE ! no-fraction case
846	frac_str = ''
847	ENDIF
848	END SUBROUTINE fraction_to_stringi8
849
850
851	! Convert fraction to string with leading sign.
852	! If fraction simplifies to a whole number or if
853	! denominator is zero, return empty string.
854	! INTEGER interface.
855	SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
856	USE ESMF_basemod
857	IMPLICIT NONE
858	INTEGER, INTENT(IN) :: numerator
859	INTEGER, INTENT(IN) :: denominator
860	CHARACTER (LEN=*), INTENT(OUT) :: frac_str
861	! locals
862	INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
863	numerator_i8 = INT( numerator, ESMF_KIND_I8 )
864	denominator_i8 = INT( denominator, ESMF_KIND_I8 )
865	CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
866	END SUBROUTINE fraction_to_string
867
868
869	SUBROUTINE print_a_time( time )
870	use ESMF_basemod
871	use ESMF_Timemod
872	IMPLICIT NONE
873	type(ESMF_Time) time
874	character*128 :: s
875	integer rc
876	CALL ESMF_TimeGet( time, timeString=s, rc=rc )
877	print *,'Print a time\|',TRIM(s),'\|'
878	write(0,*)'Print a time\|',TRIM(s),'\|'
879	return
880	END SUBROUTINE print_a_time
881
882	SUBROUTINE print_a_timeinterval( time )
883	use ESMF_basemod
884	use ESMF_TimeIntervalmod
885	IMPLICIT NONE
886	type(ESMF_TimeInterval) time
887	character*128 :: s
888	integer rc
889	CALL ESMFold_TimeIntervalGetString( time, s, rc )
890	print *,'Print a time interval\|',TRIM(s),'\|'
891	write(0,*)'Print a time interval\|',TRIM(s),'\|'
892	return
893	END SUBROUTINE print_a_timeinterval
894

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

Download in other formats:

Original Format