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 ierr = ESMF_FAILURE
365 ELSE
366 ! PRINT *,'DEBUG: timeaddmonths(): MM = ',MM
367 ! PRINT *,'DEBUG: timeaddmonths(): time%YR = ',time%YR
368 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%S = ',time%basetime%S
369 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sn = ',time%basetime%Sn
370 ! PRINT *,'DEBUG: timeaddmonths(): time%basetime%Sd = ',time%basetime%Sd
371 IF ( nfeb(time%YR) == 29 ) THEN
372 ! PRINT *,'DEBUG: timeaddmonths(): leap year'
373 MMbdys => monthbdysleap
374 ELSE
375 ! PRINT *,'DEBUG: timeaddmonths(): not leap year'
376 MMbdys => monthbdys
377 ENDIF
378 ! PRINT *,'DEBUG: timeaddmonths(): done pointing to MMbdys'
379 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%S = ',MMbdys(MM-1)%S
380 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sn = ',MMbdys(MM-1)%Sn
381 ! PRINT *,'DEBUG: timeaddmonths(): MMbdys(',MM-1,')%Sd = ',MMbdys(MM-1)%Sd
382 time%basetime = time%basetime + MMbdys(MM-1)
383 ! PRINT *,'DEBUG: END timeaddmonths()'
384 ENDIF
385 END SUBROUTINE timeaddmonths
386
387
388 ! Increment Time by number of seconds in the current month.
389 ! Time is NOT normalized.
390 SUBROUTINE timeincmonth( time )
391 USE esmf_basemod
392 USE esmf_basetimemod
393 USE esmf_timemod
394 USE esmf_calendarmod
395 IMPLICIT NONE
396 TYPE(ESMF_Time), INTENT(INOUT) :: time
397 ! locals
398 INTEGER :: nfeb
399 INTEGER :: MM
400 CALL timegetmonth( time, MM )
401 IF ( nfeb(time%YR) == 29 ) THEN
402 time%basetime%S = time%basetime%S + &
403 ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
404 ELSE
405 time%basetime%S = time%basetime%S + &
406 ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
407 ENDIF
408 END SUBROUTINE timeincmonth
409
410
411
412 ! Decrement Time by number of seconds in the previous month.
413 ! Time is NOT normalized.
414 SUBROUTINE timedecmonth( time )
415 USE esmf_basemod
416 USE esmf_basetimemod
417 USE esmf_timemod
418 USE esmf_calendarmod
419 IMPLICIT NONE
420 TYPE(ESMF_Time), INTENT(INOUT) :: time
421 ! locals
422 INTEGER :: nfeb
423 INTEGER :: MM
424 CALL timegetmonth( time, MM ) ! current month, 1-12
425 ! find previous month
426 MM = MM - 1
427 IF ( MM == 0 ) THEN
428 ! wrap around Jan -> Dec
429 MM = MONTHS_PER_YEAR
430 ENDIF
431 IF ( nfeb(time%YR) == 29 ) THEN
432 time%basetime%S = time%basetime%S - &
433 ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
434 ELSE
435 time%basetime%S = time%basetime%S - &
436 ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
437 ENDIF
438 END SUBROUTINE timedecmonth
439
440
441
442 ! spaceship operator for Times
443 SUBROUTINE timecmp(time1, time2, retval )
444 USE esmf_basemod
445 USE esmf_basetimemod
446 USE esmf_timemod
447 IMPLICIT NONE
448 INTEGER, INTENT(OUT) :: retval
449 !
450 ! !ARGUMENTS:
451 TYPE(ESMF_Time), INTENT(IN) :: time1
452 TYPE(ESMF_Time), INTENT(IN) :: time2
453 IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF
454 IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF
455 CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, &
456 time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, &
457 retval )
458 END SUBROUTINE timecmp
459
460
461
462 ! spaceship operator for TimeIntervals
463 SUBROUTINE timeintcmp(timeint1, timeint2, retval )
464 USE esmf_basemod
465 USE esmf_basetimemod
466 USE esmf_timeintervalmod
467 IMPLICIT NONE
468 INTEGER, INTENT(OUT) :: retval
469 !
470 ! !ARGUMENTS:
471 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
472 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
473 CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' )
474 CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' )
475 CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, &
476 timeint1%basetime%Sd, &
477 timeint2%basetime%S, timeint2%basetime%Sn, &
478 timeint2%basetime%Sd, retval )
479 END SUBROUTINE timeintcmp
480
481
482
483 ! spaceship operator for seconds + Sn/Sd
484 SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval )
485 USE esmf_basemod
486 IMPLICIT NONE
487 INTEGER, INTENT(OUT) :: retval
488 !
489 ! !ARGUMENTS:
490 INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1
491 INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2
492 ! local
493 INTEGER(ESMF_KIND_I8) :: lcd, n1, n2
494
495 n1 = Sn1
496 n2 = Sn2
497 if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then
498 CALL compute_lcd( Sd1, Sd2, lcd )
499 if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 )
500 if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 )
501 endif
502
503 if ( S1 .GT. S2 ) retval = 1
504 if ( S1 .LT. S2 ) retval = -1
505 IF ( S1 .EQ. S2 ) THEN
506 IF (n1 .GT. n2) retval = 1
507 IF (n1 .LT. n2) retval = -1
508 IF (n1 .EQ. n2) retval = 0
509 ENDIF
510 END SUBROUTINE seccmp
511
512
513 SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag)
514 USE esmf_alarmmod
515 USE esmf_basemod
516 USE esmf_basetimemod
517 USE esmf_calendarmod
518 USE esmf_clockmod
519 USE esmf_fractionmod
520 USE esmf_timeintervalmod
521 USE esmf_timemod
522 IMPLICIT NONE
523 logical, intent(OUT) :: outflag
524 type(ESMF_Time), intent(in) :: time1
525 type(ESMF_Time), intent(in) :: time2
526 integer res
527 CALL timecmp(time1,time2,res)
528 outflag = (res .EQ. 0)
529 END SUBROUTINE c_esmc_basetimeeq
530 SUBROUTINE c_esmc_basetimege(time1, time2, outflag)
531 USE esmf_alarmmod
532 USE esmf_basemod
533 USE esmf_basetimemod
534 USE esmf_calendarmod
535 USE esmf_clockmod
536 USE esmf_fractionmod
537 USE esmf_timeintervalmod
538 USE esmf_timemod
539 logical, intent(OUT) :: outflag
540 type(ESMF_Time), intent(in) :: time1
541 type(ESMF_Time), intent(in) :: time2
542 integer res
543 CALL timecmp(time1,time2,res)
544 outflag = (res .EQ. 1 .OR. res .EQ. 0)
545 END SUBROUTINE c_esmc_basetimege
546 SUBROUTINE c_esmc_basetimegt(time1, time2, outflag)
547 USE esmf_alarmmod
548 USE esmf_basemod
549 USE esmf_basetimemod
550 USE esmf_calendarmod
551 USE esmf_clockmod
552 USE esmf_fractionmod
553 USE esmf_timeintervalmod
554 USE esmf_timemod
555 IMPLICIT NONE
556 logical, intent(OUT) :: outflag
557 type(ESMF_Time), intent(in) :: time1
558 type(ESMF_Time), intent(in) :: time2
559 integer res
560 CALL timecmp(time1,time2,res)
561 outflag = (res .EQ. 1)
562 END SUBROUTINE c_esmc_basetimegt
563 SUBROUTINE c_esmc_basetimele(time1, time2, outflag)
564 USE esmf_alarmmod
565 USE esmf_basemod
566 USE esmf_basetimemod
567 USE esmf_calendarmod
568 USE esmf_clockmod
569 USE esmf_fractionmod
570 USE esmf_timeintervalmod
571 USE esmf_timemod
572 IMPLICIT NONE
573 logical, intent(OUT) :: outflag
574 type(ESMF_Time), intent(in) :: time1
575 type(ESMF_Time), intent(in) :: time2
576 integer res
577 CALL timecmp(time1,time2,res)
578 outflag = (res .EQ. -1 .OR. res .EQ. 0)
579 END SUBROUTINE c_esmc_basetimele
580 SUBROUTINE c_esmc_basetimelt(time1, time2, outflag)
581 USE esmf_alarmmod
582 USE esmf_basemod
583 USE esmf_basetimemod
584 USE esmf_calendarmod
585 USE esmf_clockmod
586 USE esmf_fractionmod
587 USE esmf_timeintervalmod
588 USE esmf_timemod
589 IMPLICIT NONE
590 logical, intent(OUT) :: outflag
591 type(ESMF_Time), intent(in) :: time1
592 type(ESMF_Time), intent(in) :: time2
593 integer res
594 CALL timecmp(time1,time2,res)
595 outflag = (res .EQ. -1)
596 END SUBROUTINE c_esmc_basetimelt
597 SUBROUTINE c_esmc_basetimene(time1, time2, outflag)
598 USE esmf_alarmmod
599 USE esmf_basemod
600 USE esmf_basetimemod
601 USE esmf_calendarmod
602 USE esmf_clockmod
603 USE esmf_fractionmod
604 USE esmf_timeintervalmod
605 USE esmf_timemod
606 IMPLICIT NONE
607 logical, intent(OUT) :: outflag
608 type(ESMF_Time), intent(in) :: time1
609 type(ESMF_Time), intent(in) :: time2
610 integer res
611 CALL timecmp(time1,time2,res)
612 outflag = (res .NE. 0)
613 END SUBROUTINE c_esmc_basetimene
614
615 SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag)
616 USE esmf_timeintervalmod
617 IMPLICIT NONE
618 LOGICAL, INTENT(OUT) :: outflag
619 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
620 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
621 INTEGER :: res
622 CALL timeintcmp(timeint1,timeint2,res)
623 outflag = (res .EQ. 0)
624 END SUBROUTINE c_esmc_basetimeinteq
625 SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag)
626 USE esmf_timeintervalmod
627 IMPLICIT NONE
628 LOGICAL, INTENT(OUT) :: outflag
629 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
630 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
631 INTEGER :: res
632 CALL timeintcmp(timeint1,timeint2,res)
633 outflag = (res .NE. 0)
634 END SUBROUTINE c_esmc_basetimeintne
635 SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag)
636 USE esmf_timeintervalmod
637 IMPLICIT NONE
638 LOGICAL, INTENT(OUT) :: outflag
639 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
640 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
641 INTEGER :: res
642 CALL timeintcmp(timeint1,timeint2,res)
643 outflag = (res .LT. 0)
644 END SUBROUTINE c_esmc_basetimeintlt
645 SUBROUTINE c_esmc_basetimeintgt(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 .GT. 0)
654 END SUBROUTINE c_esmc_basetimeintgt
655 SUBROUTINE c_esmc_basetimeintle(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 .LE. 0)
664 END SUBROUTINE c_esmc_basetimeintle
665 SUBROUTINE c_esmc_basetimeintge(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 .GE. 0)
674 END SUBROUTINE c_esmc_basetimeintge
675
676 SUBROUTINE compute_lcd( e1, e2, lcd )
677 USE esmf_basemod
678 IMPLICIT NONE
679 INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2
680 INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd
681 INTEGER, PARAMETER :: nprimes = 9
682 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
683 INTEGER i
684 INTEGER(ESMF_KIND_I8) d1, d2, p
685
686 d1 = e1 ; d2 = e2
687 IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF
688 IF ( d1 .EQ. 0 ) d1 = d2
689 IF ( d2 .EQ. 0 ) d2 = d1
690 IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF
691 lcd = d1 * d2
692 DO i = 1, nprimes
693 p = primes(i)
694 DO WHILE (lcd/p .NE. 0 .AND. &
695 mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0)
696 lcd = lcd / p
697 END DO
698 ENDDO
699 END SUBROUTINE compute_lcd
700
701 SUBROUTINE simplify( ni, di, no, do )
702 USE esmf_basemod
703 IMPLICIT NONE
704 INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di
705 INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
706 INTEGER, PARAMETER :: nprimes = 9
707 INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
708 INTEGER(ESMF_KIND_I8) :: pr, d, n
709 INTEGER :: np
710 LOGICAL keepgoing
711 IF ( ni .EQ. 0 ) THEN
712 do = 1
713 no = 0
714 RETURN
715 ENDIF
716 IF ( mod( di , ni ) .EQ. 0 ) THEN
717 do = di / ni
718 no = 1
719 RETURN
720 ENDIF
721 d = di
722 n = ni
723 DO np = 1, nprimes
724 pr = primes(np)
725 keepgoing = .TRUE.
726 DO WHILE ( keepgoing )
727 keepgoing = .FALSE.
728 IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
729 d = d / pr
730 n = n / pr
731 keepgoing = .TRUE.
732 ENDIF
733 ENDDO
734 ENDDO
735 do = d
736 no = n
737 RETURN
738 END SUBROUTINE simplify
739
740
741 !$$$ this should be named "c_esmc_timesum" or something less misleading
742 SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
743 USE esmf_basemod
744 USE esmf_basetimemod
745 USE esmf_timeintervalmod
746 USE esmf_timemod
747 IMPLICIT NONE
748 TYPE(ESMF_Time), INTENT(IN) :: time1
749 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
750 TYPE(ESMF_Time), INTENT(INOUT) :: timeOut
751 ! locals
752 INTEGER :: m
753 timeOut = time1
754 timeOut%basetime = timeOut%basetime + timeinterval%basetime
755 DO m = 1, abs(timeinterval%MM)
756 IF ( timeinterval%MM > 0 ) THEN
757 CALL timeincmonth( timeOut )
758 ELSE
759 CALL timedecmonth( timeOut )
760 ENDIF
761 ENDDO
762 timeOut%YR = timeOut%YR + timeinterval%YR
763 CALL normalize_time( timeOut )
764 END SUBROUTINE c_esmc_basetimesum
765
766
767 !$$$ this should be named "c_esmc_timedec" or something less misleading
768 SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut )
769 USE esmf_basemod
770 USE esmf_basetimemod
771 USE esmf_timeintervalmod
772 USE esmf_timemod
773 IMPLICIT NONE
774 TYPE(ESMF_Time), INTENT(IN) :: time1
775 TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
776 TYPE(ESMF_Time), INTENT(OUT) :: timeOut
777 ! locals
778 TYPE (ESMF_TimeInterval) :: neginterval
779 neginterval = timeinterval
780 !$$$push this down into a unary negation operator on TimeInterval
781 neginterval%basetime%S = -neginterval%basetime%S
782 neginterval%basetime%Sn = -neginterval%basetime%Sn
783 neginterval%YR = -neginterval%YR
784 neginterval%MM = -neginterval%MM
785 timeOut = time1 + neginterval
786 END SUBROUTINE c_esmc_basetimedec
787
788
789 !$$$ this should be named "c_esmc_timediff" or something less misleading
790 SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut )
791 USE esmf_basemod
792 USE esmf_basetimemod
793 USE esmf_timeintervalmod
794 USE esmf_timemod
795 IMPLICIT NONE
796 TYPE(ESMF_Time), INTENT(IN) :: time1
797 TYPE(ESMF_Time), INTENT(IN) :: time2
798 TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut
799 ! locals
800 INTEGER(ESMF_KIND_I8) :: nsecondsinyear
801 INTEGER :: yr
802 CALL ESMF_TimeIntervalSet( timeIntOut )
803 timeIntOut%basetime = time1%basetime - time2%basetime
804 ! convert difference in years to basetime...
805 IF ( time1%YR > time2%YR ) THEN
806 DO yr = time2%YR, ( time1%YR - 1 )
807 timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr )
808 ENDDO
809 ELSE IF ( time2%YR > time1%YR ) THEN
810 DO yr = time1%YR, ( time2%YR - 1 )
811 timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr )
812 ENDDO
813 ENDIF
814 !$$$ add tests for multi-year differences
815 CALL normalize_timeint( timeIntOut )
816 END SUBROUTINE c_esmc_basetimediff
817
818
819 ! some extra wrf stuff
820
821
822 ! Convert fraction to string with leading sign.
823 ! If fraction simplifies to a whole number or if
824 ! denominator is zero, return empty string.
825 ! INTEGER*8 interface.
826 SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
827 USE ESMF_basemod
828 IMPLICIT NONE
829 INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
830 INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
831 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
832 IF ( denominator > 0 ) THEN
833 IF ( mod( numerator, denominator ) /= 0 ) THEN
834 IF ( numerator > 0 ) THEN
835 WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
836 ELSE ! numerator < 0
837 WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
838 ENDIF
839 ELSE ! includes numerator == 0 case
840 frac_str = ''
841 ENDIF
842 ELSE ! no-fraction case
843 frac_str = ''
844 ENDIF
845 END SUBROUTINE fraction_to_stringi8
846
847
848 ! Convert fraction to string with leading sign.
849 ! If fraction simplifies to a whole number or if
850 ! denominator is zero, return empty string.
851 ! INTEGER interface.
852 SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
853 USE ESMF_basemod
854 IMPLICIT NONE
855 INTEGER, INTENT(IN) :: numerator
856 INTEGER, INTENT(IN) :: denominator
857 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
858 ! locals
859 INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
860 numerator_i8 = INT( numerator, ESMF_KIND_I8 )
861 denominator_i8 = INT( denominator, ESMF_KIND_I8 )
862 CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
863 END SUBROUTINE fraction_to_string
864
865
866 SUBROUTINE print_a_time( time )
867 use ESMF_basemod
868 use ESMF_Timemod
869 IMPLICIT NONE
870 type(ESMF_Time) time
871 character*128 :: s
872 integer rc
873 CALL ESMF_TimeGet( time, timeString=s, rc=rc )
874 print *,'Print a time|',TRIM(s),'|'
875 write(0,*)'Print a time|',TRIM(s),'|'
876 return
877 END SUBROUTINE print_a_time
878
879 SUBROUTINE print_a_timeinterval( time )
880 use ESMF_basemod
881 use ESMF_TimeIntervalmod
882 IMPLICIT NONE
883 type(ESMF_TimeInterval) time
884 character*128 :: s
885 integer rc
886 CALL ESMFold_TimeIntervalGetString( time, s, rc )
887 print *,'Print a time interval|',TRIM(s),'|'
888 write(0,*)'Print a time interval|',TRIM(s),'|'
889 return
890 END SUBROUTINE print_a_timeinterval
891