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