Meat.F90
References to this file elsewhere.
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 ! TBH: TODO: Replace this hack with run-time decision based on
177 ! TBH: TODO: passed-in calendar.
178 #ifdef NO_LEAP_CALENDAR
179 num_days = 28 ! By default, February has 28 days ...
180 #else
181 num_days = 28 ! By default, February has 28 days ...
182 IF (MOD(year,4).eq.0) THEN
183 num_days = 29 ! But every four years, it has 29 days ...
184 IF (MOD(year,100).eq.0) THEN
185 num_days = 28 ! Except every 100 years, when it has 28 days ...
186 IF (MOD(year,400).eq.0) THEN
187 num_days = 29 ! Except every 400 years, when it has 29 days.
188 END IF
189 END IF
190 END IF
191 #endif
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 END FUNCTION ndaysinyear
208
209
210
211 FUNCTION nsecondsinyear ( year ) RESULT (numseconds)
212 ! Compute the number of seconds in the given year
213 USE esmf_basemod
214 IMPLICIT NONE
215 INTEGER, INTENT(IN) :: year
216 INTEGER(ESMF_KIND_I8) :: numseconds
217 INTEGER :: ndaysinyear
218 numseconds = SECONDS_PER_DAY * INT( ndaysinyear(year) , ESMF_KIND_I8 )
219 END FUNCTION nsecondsinyear
220
221
222
223 SUBROUTINE initdaym
224 USE esmf_basemod
225 USE esmf_basetimemod
226 USE ESMF_CalendarMod
227 IMPLICIT NONE
228 INTEGER i,j,m
229 m = 1
230 mdaycum(0) = 0
231 !$$$ push this down into ESMF_BaseTime constructor
232 monthbdys(0)%S = 0
233 monthbdys(0)%Sn = 0
234 monthbdys(0)%Sd = 0
235 DO i = 1,MONTHS_PER_YEAR
236 DO j = 1,mday(i)
237 daym(m) = i
238 m = m + 1
239 ENDDO
240 mdaycum(i) = mdaycum(i-1) + mday(i)
241 !$$$ push this down into ESMF_BaseTime constructor
242 monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 )
243 monthbdys(i)%Sn = 0
244 monthbdys(i)%Sd = 0
245 ENDDO
246 m = 1
247 mdayleapcum(0) = 0
248 !$$$ push this down into ESMF_BaseTime constructor
249 monthbdysleap(0)%S = 0
250 monthbdysleap(0)%Sn = 0
251 monthbdysleap(0)%Sd = 0
252 DO i = 1,MONTHS_PER_YEAR
253 DO j = 1,mdayleap(i)
254 daymleap(m) = i
255 m = m + 1
256 ENDDO
257 mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i)
258 !$$$ push this down into ESMF_BaseTime constructor
259 monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 )
260 monthbdysleap(i)%Sn = 0
261 monthbdysleap(i)%Sd = 0
262 ENDDO
263 END SUBROUTINE initdaym
264
265
266 !$$$ useful, but not used at the moment...
267 SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear)
268 use ESMF_CalendarMod
269 IMPLICIT NONE
270 INTEGER, INTENT(IN) :: YR,MM,DD ! DD is day of month
271 INTEGER, INTENT(OUT) :: dayinyear
272 INTEGER i
273 integer nfeb
274
275 dayinyear = 0
276 DO i = 1,MM-1
277 if (i.eq.2) then
278 dayinyear = dayinyear + nfeb(YR)
279 else
280 dayinyear = dayinyear + mday(i)
281 endif
282 ENDDO
283 dayinyear = dayinyear + DD
284 END SUBROUTINE compute_dayinyear
285
286
287
288 SUBROUTINE timegetmonth( time, MM )
289 USE esmf_basemod
290 USE esmf_basetimemod
291 USE esmf_timemod
292 USE esmf_calendarmod
293 IMPLICIT NONE
294 TYPE(ESMF_Time), INTENT(IN) :: time
295 INTEGER, INTENT(OUT) :: MM
296 ! locals
297 INTEGER :: nfeb
298 INTEGER :: i
299 TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
300 IF ( nfeb(time%YR) == 29 ) THEN
301 MMbdys => monthbdysleap
302 ELSE
303 MMbdys => monthbdys
304 ENDIF
305 MM = -1
306 DO i = 1,MONTHS_PER_YEAR
307 IF ( ( time%basetime >= MMbdys(i-1) ) .AND. ( time%basetime < MMbdys(i) ) ) THEN
308 MM = i
309 EXIT
310 ENDIF
311 ENDDO
312 IF ( MM == -1 ) THEN
313 CALL wrf_error_fatal( 'timegetmonth: could not extract month of year from time' )
314 ENDIF
315 END SUBROUTINE timegetmonth
316
317
318 !$$$ may need to change dependencies in Makefile...
319
320 SUBROUTINE timegetdayofmonth( time, DD )
321 USE esmf_basemod
322 USE esmf_basetimemod
323 USE esmf_timemod
324 USE esmf_calendarmod
325 IMPLICIT NONE
326 TYPE(ESMF_Time), INTENT(IN) :: time
327 INTEGER, INTENT(OUT) :: DD
328 ! locals
329 INTEGER :: nfeb
330 INTEGER :: MM
331 TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
332 TYPE(ESMF_BaseTime) :: tmpbasetime
333 !$$$ fix this so init just points MMbdys to the one we want for this calendar?
334 IF ( nfeb(time%YR) == 29 ) THEN
335 MMbdys => monthbdysleap
336 ELSE
337 MMbdys => monthbdys
338 ENDIF
339 CALL timegetmonth( time, MM )
340 tmpbasetime = time%basetime - MMbdys(MM-1)
341 DD = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1
342 END SUBROUTINE timegetdayofmonth
343
344
345 ! Increment Time by number of seconds between start of year and start
346 ! of month MM.
347 ! 1 <= MM <= 12
348 ! Time is NOT normalized.
349 SUBROUTINE timeaddmonths( time, MM, ierr )
350 USE esmf_basemod
351 USE esmf_basetimemod
352 USE esmf_timemod
353 USE esmf_calendarmod
354 IMPLICIT NONE
355 TYPE(ESMF_Time), INTENT(INOUT) :: time
356 INTEGER, INTENT(IN) :: MM
357 INTEGER, INTENT(OUT) :: ierr
358 ! locals
359 INTEGER :: nfeb
360 TYPE(ESMF_BaseTime), POINTER :: MMbdys(:)
361 ierr = ESMF_SUCCESS
362 ! PRINT *,'DEBUG: BEGIN timeaddmonths()'
363 IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN
364 CALL wrf_message( 'ERROR timeaddmonths(): MM out of range' )
365 ierr = ESMF_FAILURE
366 ENDIF
367 ! PRINT *,'DEBUG: timeaddmonths(): MM = ',MM
368 !$$$ fix this so init just points MMbdys to the one we want for this calendar?
369 ! PRINT *,'DEBUG: timeaddmonths(): time%YR = ',time%YR
370 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%S = ',time%basetime%S
371 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sn = ',time%basetime%Sn
372 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sd = ',time%basetime%Sd
373 IF ( nfeb(time%YR) == 29 ) THEN
374 ! PRINT *,'DEBUG: timeaddmonths(): leap year'
375 MMbdys => monthbdysleap
376 ELSE
377 ! PRINT *,'DEBUG: timeaddmonths(): not leap year'
378 MMbdys => monthbdys
379 ENDIF
380 ! PRINT *,'DEBUG: timeaddmonths(): done pointing to MMbdys'
381 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%S = ',MMbdys(MM-1)%S
382 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sn = ',MMbdys(MM-1)%Sn
383 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sd = ',MMbdys(MM-1)%Sd
384 !$$$ dumps core here...
385 time%basetime = time%basetime + MMbdys(MM-1)
386 ! PRINT *,'DEBUG: END timeaddmonths()'
387 END SUBROUTINE timeaddmonths
388
389
390 ! Increment Time by number of seconds in the current month.
391 ! Time is NOT normalized.
392 SUBROUTINE timeincmonth( time )
393 USE esmf_basemod
394 USE esmf_basetimemod
395 USE esmf_timemod
396 USE esmf_calendarmod
397 IMPLICIT NONE
398 TYPE(ESMF_Time), INTENT(INOUT) :: time
399 ! locals
400 INTEGER :: nfeb
401 INTEGER :: MM
402 CALL timegetmonth( time, MM )
403 IF ( nfeb(time%YR) == 29 ) THEN
404 time%basetime%S = time%basetime%S + &
405 ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
406 ELSE
407 time%basetime%S = time%basetime%S + &
408 ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
409 ENDIF
410 END SUBROUTINE timeincmonth
411
412
413
414 ! Decrement Time by number of seconds in the previous month.
415 ! Time is NOT normalized.
416 SUBROUTINE timedecmonth( time )
417 USE esmf_basemod
418 USE esmf_basetimemod
419 USE esmf_timemod
420 USE esmf_calendarmod
421 IMPLICIT NONE
422 TYPE(ESMF_Time), INTENT(INOUT) :: time
423 ! locals
424 INTEGER :: nfeb
425 INTEGER :: MM
426 CALL timegetmonth( time, MM ) ! current month, 1-12
427 ! find previous month
428 MM = MM - 1
429 IF ( MM == 0 ) THEN
430 ! wrap around Jan -> Dec
431 MM = MONTHS_PER_YEAR
432 ENDIF
433 IF ( nfeb(time%YR) == 29 ) THEN
434 time%basetime%S = time%basetime%S - &
435 ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
436 ELSE
437 time%basetime%S = time%basetime%S - &
438 ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
439 ENDIF
440 END SUBROUTINE timedecmonth
441
442
443
444 ! spaceship operator for Times
445 SUBROUTINE timecmp(time1, time2, retval )
446 USE esmf_basemod
447 USE esmf_basetimemod
448 USE esmf_timemod
449 IMPLICIT NONE
450 INTEGER, INTENT(OUT) :: retval
451 !
452 ! !ARGUMENTS:
453 TYPE(ESMF_Time), INTENT(IN) :: time1
454 TYPE(ESMF_Time), INTENT(IN) :: time2
455 IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF
456 IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF
457 CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, &
458 time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, &
459 retval )
460 END SUBROUTINE timecmp
461
462
463
464 ! spaceship operator for TimeIntervals
465 SUBROUTINE timeintcmp(timeint1, timeint2, retval )
466 USE esmf_basemod
467 USE esmf_basetimemod
468 USE esmf_timeintervalmod
469 IMPLICIT NONE
470 INTEGER, INTENT(OUT) :: retval
471 !
472 ! !ARGUMENTS:
473 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
474 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
475 CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' )
476 CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' )
477 CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, &
478 timeint1%basetime%Sd, &
479 timeint2%basetime%S, timeint2%basetime%Sn, &
480 timeint2%basetime%Sd, retval )
481 END SUBROUTINE timeintcmp
482
483
484
485 ! spaceship operator for seconds + Sn/Sd
486 SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval )
487 USE esmf_basemod
488 IMPLICIT NONE
489 INTEGER, INTENT(OUT) :: retval
490 !
491 ! !ARGUMENTS:
492 INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1
493 INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2
494 ! local
495 INTEGER(ESMF_KIND_I8) :: lcd, n1, n2
496
497 n1 = Sn1
498 n2 = Sn2
499 if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then
500 CALL compute_lcd( Sd1, Sd2, lcd )
501 if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 )
502 if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 )
503 endif
504
505 if ( S1 .GT. S2 ) retval = 1
506 if ( S1 .LT. S2 ) retval = -1
507 IF ( S1 .EQ. S2 ) THEN
508 IF (n1 .GT. n2) retval = 1
509 IF (n1 .LT. n2) retval = -1
510 IF (n1 .EQ. n2) retval = 0
511 ENDIF
512 END SUBROUTINE seccmp
513
514
515 SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag)
516 USE esmf_alarmmod
517 USE esmf_basemod
518 USE esmf_basetimemod
519 USE esmf_calendarmod
520 USE esmf_clockmod
521 USE esmf_fractionmod
522 USE esmf_timeintervalmod
523 USE esmf_timemod
524 IMPLICIT NONE
525 logical, intent(OUT) :: outflag
526 type(ESMF_Time), intent(in) :: time1
527 type(ESMF_Time), intent(in) :: time2
528 integer res
529 CALL timecmp(time1,time2,res)
530 outflag = (res .EQ. 0)
531 END SUBROUTINE c_esmc_basetimeeq
532 SUBROUTINE c_esmc_basetimege(time1, time2, outflag)
533 USE esmf_alarmmod
534 USE esmf_basemod
535 USE esmf_basetimemod
536 USE esmf_calendarmod
537 USE esmf_clockmod
538 USE esmf_fractionmod
539 USE esmf_timeintervalmod
540 USE esmf_timemod
541 logical, intent(OUT) :: outflag
542 type(ESMF_Time), intent(in) :: time1
543 type(ESMF_Time), intent(in) :: time2
544 integer res
545 CALL timecmp(time1,time2,res)
546 outflag = (res .EQ. 1 .OR. res .EQ. 0)
547 END SUBROUTINE c_esmc_basetimege
548 SUBROUTINE c_esmc_basetimegt(time1, time2, outflag)
549 USE esmf_alarmmod
550 USE esmf_basemod
551 USE esmf_basetimemod
552 USE esmf_calendarmod
553 USE esmf_clockmod
554 USE esmf_fractionmod
555 USE esmf_timeintervalmod
556 USE esmf_timemod
557 IMPLICIT NONE
558 logical, intent(OUT) :: outflag
559 type(ESMF_Time), intent(in) :: time1
560 type(ESMF_Time), intent(in) :: time2
561 integer res
562 CALL timecmp(time1,time2,res)
563 outflag = (res .EQ. 1)
564 END SUBROUTINE c_esmc_basetimegt
565 SUBROUTINE c_esmc_basetimele(time1, time2, outflag)
566 USE esmf_alarmmod
567 USE esmf_basemod
568 USE esmf_basetimemod
569 USE esmf_calendarmod
570 USE esmf_clockmod
571 USE esmf_fractionmod
572 USE esmf_timeintervalmod
573 USE esmf_timemod
574 IMPLICIT NONE
575 logical, intent(OUT) :: outflag
576 type(ESMF_Time), intent(in) :: time1
577 type(ESMF_Time), intent(in) :: time2
578 integer res
579 CALL timecmp(time1,time2,res)
580 outflag = (res .EQ. -1 .OR. res .EQ. 0)
581 END SUBROUTINE c_esmc_basetimele
582 SUBROUTINE c_esmc_basetimelt(time1, time2, outflag)
583 USE esmf_alarmmod
584 USE esmf_basemod
585 USE esmf_basetimemod
586 USE esmf_calendarmod
587 USE esmf_clockmod
588 USE esmf_fractionmod
589 USE esmf_timeintervalmod
590 USE esmf_timemod
591 IMPLICIT NONE
592 logical, intent(OUT) :: outflag
593 type(ESMF_Time), intent(in) :: time1
594 type(ESMF_Time), intent(in) :: time2
595 integer res
596 CALL timecmp(time1,time2,res)
597 outflag = (res .EQ. -1)
598 END SUBROUTINE c_esmc_basetimelt
599 SUBROUTINE c_esmc_basetimene(time1, time2, outflag)
600 USE esmf_alarmmod
601 USE esmf_basemod
602 USE esmf_basetimemod
603 USE esmf_calendarmod
604 USE esmf_clockmod
605 USE esmf_fractionmod
606 USE esmf_timeintervalmod
607 USE esmf_timemod
608 IMPLICIT NONE
609 logical, intent(OUT) :: outflag
610 type(ESMF_Time), intent(in) :: time1
611 type(ESMF_Time), intent(in) :: time2
612 integer res
613 CALL timecmp(time1,time2,res)
614 outflag = (res .NE. 0)
615 END SUBROUTINE c_esmc_basetimene
616
617 SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag)
618 USE esmf_timeintervalmod
619 IMPLICIT NONE
620 LOGICAL, INTENT(OUT) :: outflag
621 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
622 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
623 INTEGER :: res
624 CALL timeintcmp(timeint1,timeint2,res)
625 outflag = (res .EQ. 0)
626 END SUBROUTINE c_esmc_basetimeinteq
627 SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag)
628 USE esmf_timeintervalmod
629 IMPLICIT NONE
630 LOGICAL, INTENT(OUT) :: outflag
631 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
632 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
633 INTEGER :: res
634 CALL timeintcmp(timeint1,timeint2,res)
635 outflag = (res .NE. 0)
636 END SUBROUTINE c_esmc_basetimeintne
637 SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag)
638 USE esmf_timeintervalmod
639 IMPLICIT NONE
640 LOGICAL, INTENT(OUT) :: outflag
641 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
642 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
643 INTEGER :: res
644 CALL timeintcmp(timeint1,timeint2,res)
645 outflag = (res .LT. 0)
646 END SUBROUTINE c_esmc_basetimeintlt
647 SUBROUTINE c_esmc_basetimeintgt(timeint1, timeint2, outflag)
648 USE esmf_timeintervalmod
649 IMPLICIT NONE
650 LOGICAL, INTENT(OUT) :: outflag
651 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
652 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
653 INTEGER :: res
654 CALL timeintcmp(timeint1,timeint2,res)
655 outflag = (res .GT. 0)
656 END SUBROUTINE c_esmc_basetimeintgt
657 SUBROUTINE c_esmc_basetimeintle(timeint1, timeint2, outflag)
658 USE esmf_timeintervalmod
659 IMPLICIT NONE
660 LOGICAL, INTENT(OUT) :: outflag
661 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
662 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
663 INTEGER :: res
664 CALL timeintcmp(timeint1,timeint2,res)
665 outflag = (res .LE. 0)
666 END SUBROUTINE c_esmc_basetimeintle
667 SUBROUTINE c_esmc_basetimeintge(timeint1, timeint2, outflag)
668 USE esmf_timeintervalmod
669 IMPLICIT NONE
670 LOGICAL, INTENT(OUT) :: outflag
671 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
672 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
673 INTEGER :: res
674 CALL timeintcmp(timeint1,timeint2,res)
675 outflag = (res .GE. 0)
676 END SUBROUTINE c_esmc_basetimeintge
677
678 SUBROUTINE compute_lcd( e1, e2, lcd )
679 USE esmf_basemod
680 IMPLICIT NONE
681 INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2
682 INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd
683 INTEGER, PARAMETER :: nprimes = 9
684 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
685 INTEGER i
686 INTEGER(ESMF_KIND_I8) d1, d2, p
687
688 d1 = e1 ; d2 = e2
689 IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF
690 IF ( d1 .EQ. 0 ) d1 = d2
691 IF ( d2 .EQ. 0 ) d2 = d1
692 IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF
693 lcd = d1 * d2
694 DO i = 1, nprimes
695 p = primes(i)
696 DO WHILE (lcd/p .NE. 0 .AND. &
697 mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0)
698 lcd = lcd / p
699 END DO
700 ENDDO
701 END SUBROUTINE compute_lcd
702
703 SUBROUTINE simplify( ni, di, no, do )
704 USE esmf_basemod
705 IMPLICIT NONE
706 INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di
707 INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
708 INTEGER, PARAMETER :: nprimes = 9
709 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
710 INTEGER(ESMF_KIND_I8) :: pr, d, n
711 INTEGER :: np
712 LOGICAL keepgoing
713 IF ( ni .EQ. 0 ) THEN
714 do = 1
715 no = 0
716 RETURN
717 ENDIF
718 IF ( mod( di , ni ) .EQ. 0 ) THEN
719 do = di / ni
720 no = 1
721 RETURN
722 ENDIF
723 d = di
724 n = ni
725 DO np = 1, nprimes
726 pr = primes(np)
727 keepgoing = .TRUE.
728 DO WHILE ( keepgoing )
729 keepgoing = .FALSE.
730 IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
731 d = d / pr
732 n = n / pr
733 keepgoing = .TRUE.
734 ENDIF
735 ENDDO
736 ENDDO
737 do = d
738 no = n
739 RETURN
740 END SUBROUTINE simplify
741
742
743 !$$$ this should be named "c_esmc_timesum" or something less misleading
744 SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
745 USE esmf_basemod
746 USE esmf_basetimemod
747 USE esmf_timeintervalmod
748 USE esmf_timemod
749 IMPLICIT NONE
750 TYPE(ESMF_Time), INTENT(IN) :: time1
751 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
752 TYPE(ESMF_Time), INTENT(INOUT) :: timeOut
753 ! locals
754 INTEGER :: m
755 timeOut = time1
756 timeOut%basetime = timeOut%basetime + timeinterval%basetime
757 DO m = 1, abs(timeinterval%MM)
758 IF ( timeinterval%MM > 0 ) THEN
759 CALL timeincmonth( timeOut )
760 ELSE
761 CALL timedecmonth( timeOut )
762 ENDIF
763 ENDDO
764 timeOut%YR = timeOut%YR + timeinterval%YR
765 CALL normalize_time( timeOut )
766 END SUBROUTINE c_esmc_basetimesum
767
768
769 !$$$ this should be named "c_esmc_timedec" or something less misleading
770 SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut )
771 USE esmf_basemod
772 USE esmf_basetimemod
773 USE esmf_timeintervalmod
774 USE esmf_timemod
775 IMPLICIT NONE
776 TYPE(ESMF_Time), INTENT(IN) :: time1
777 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
778 TYPE(ESMF_Time), INTENT(OUT) :: timeOut
779 ! locals
780 TYPE (ESMF_TimeInterval) :: neginterval
781 neginterval = timeinterval
782 !$$$push this down into a unary negation operator on TimeInterval
783 neginterval%basetime%S = -neginterval%basetime%S
784 neginterval%basetime%Sn = -neginterval%basetime%Sn
785 neginterval%YR = -neginterval%YR
786 neginterval%MM = -neginterval%MM
787 timeOut = time1 + neginterval
788 END SUBROUTINE c_esmc_basetimedec
789
790
791 !$$$ this should be named "c_esmc_timediff" or something less misleading
792 SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut )
793 USE esmf_basemod
794 USE esmf_basetimemod
795 USE esmf_timeintervalmod
796 USE esmf_timemod
797 IMPLICIT NONE
798 TYPE(ESMF_Time), INTENT(IN) :: time1
799 TYPE(ESMF_Time), INTENT(IN) :: time2
800 TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut
801 ! locals
802 INTEGER(ESMF_KIND_I8) :: nsecondsinyear
803 INTEGER :: yr
804 CALL ESMF_TimeIntervalSet( timeIntOut )
805 timeIntOut%basetime = time1%basetime - time2%basetime
806 ! convert difference in years to basetime...
807 IF ( time1%YR > time2%YR ) THEN
808 DO yr = time2%YR, ( time1%YR - 1 )
809 timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr )
810 ENDDO
811 ELSE IF ( time2%YR > time1%YR ) THEN
812 DO yr = time1%YR, ( time2%YR - 1 )
813 timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr )
814 ENDDO
815 ENDIF
816 !$$$ add tests for multi-year differences
817 CALL normalize_timeint( timeIntOut )
818 END SUBROUTINE c_esmc_basetimediff
819
820
821 ! some extra wrf stuff
822
823
824 ! Convert fraction to string with leading sign.
825 ! If fraction simplifies to a whole number or if
826 ! denominator is zero, return empty string.
827 ! INTEGER*8 interface.
828 SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
829 USE ESMF_basemod
830 IMPLICIT NONE
831 INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
832 INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
833 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
834 IF ( denominator > 0 ) THEN
835 IF ( mod( numerator, denominator ) /= 0 ) THEN
836 IF ( numerator > 0 ) THEN
837 WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
838 ELSE ! numerator < 0
839 WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
840 ENDIF
841 ELSE ! includes numerator == 0 case
842 frac_str = ''
843 ENDIF
844 ELSE ! no-fraction case
845 frac_str = ''
846 ENDIF
847 END SUBROUTINE fraction_to_stringi8
848
849
850 ! Convert fraction to string with leading sign.
851 ! If fraction simplifies to a whole number or if
852 ! denominator is zero, return empty string.
853 ! INTEGER interface.
854 SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
855 USE ESMF_basemod
856 IMPLICIT NONE
857 INTEGER, INTENT(IN) :: numerator
858 INTEGER, INTENT(IN) :: denominator
859 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
860 ! locals
861 INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
862 numerator_i8 = INT( numerator, ESMF_KIND_I8 )
863 denominator_i8 = INT( denominator, ESMF_KIND_I8 )
864 CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
865 END SUBROUTINE fraction_to_string
866
867
868 SUBROUTINE print_a_time( time )
869 use ESMF_basemod
870 use ESMF_Timemod
871 IMPLICIT NONE
872 type(ESMF_Time) time
873 character*128 :: s
874 integer rc
875 CALL ESMF_TimeGet( time, timeString=s, rc=rc )
876 print *,'Print a time|',TRIM(s),'|'
877 write(0,*)'Print a time|',TRIM(s),'|'
878 return
879 END SUBROUTINE print_a_time
880
881 SUBROUTINE print_a_timeinterval( time )
882 use ESMF_basemod
883 use ESMF_TimeIntervalmod
884 IMPLICIT NONE
885 type(ESMF_TimeInterval) time
886 character*128 :: s
887 integer rc
888 CALL ESMFold_TimeIntervalGetString( time, s, rc )
889 print *,'Print a time interval|',TRIM(s),'|'
890 write(0,*)'Print a time interval|',TRIM(s),'|'
891 return
892 END SUBROUTINE print_a_timeinterval
893