source: trunk/WRF.COMMON/WRFV3/external/esmf_time_f90/Meat.F90 @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

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