wrfv2_fire/external/esmf_time_f90/Meat.F90

   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, 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
 270 END SUBROUTINE initdaym
 271
 272
 273 !$$$ useful, but not used at the moment...
 274 SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear)
 275   use ESMF_CalendarMod, only : mday
 276 IMPLICIT 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
 295 END SUBROUTINE compute_dayinyear
 296
 297
 298
 299 SUBROUTINE 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
 333 END SUBROUTINE timegetmonth
 334
 335
 336 !$$$ may need to change dependencies in Makefile...
 337
 338 SUBROUTINE 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
 361 END 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.
 368 SUBROUTINE 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
 394 END SUBROUTINE timeaddmonths
 395
 396
 397 ! Increment Time by number of seconds in the current month.
 398 ! Time is NOT normalized.
 399 SUBROUTINE 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
 421 END SUBROUTINE timeincmonth
 422
 423
 424
 425 ! Decrement Time by number of seconds in the previous month.
 426 ! Time is NOT normalized.
 427 SUBROUTINE 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
 455 END SUBROUTINE timedecmonth
 456
 457
 458
 459 ! spaceship operator for Times
 460 SUBROUTINE 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 )
 475 END SUBROUTINE timecmp
 476
 477
 478
 479 ! spaceship operator for TimeIntervals
 480 SUBROUTINE 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 )
 496 END SUBROUTINE timeintcmp
 497
 498
 499
 500 ! spaceship operator for seconds + Sn/Sd
 501 SUBROUTINE 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
 527 END SUBROUTINE seccmp
 528
 529
 530 SUBROUTINE 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
 539 IMPLICIT 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)
 546 END SUBROUTINE c_esmc_basetimeeq
 547 SUBROUTINE 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)
 562 END SUBROUTINE c_esmc_basetimege
 563 SUBROUTINE 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
 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)
 579 END SUBROUTINE c_esmc_basetimegt
 580 SUBROUTINE 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
 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 .OR. res .EQ. 0)
 596 END SUBROUTINE c_esmc_basetimele
 597 SUBROUTINE 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
 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 .EQ. -1)
 613 END SUBROUTINE c_esmc_basetimelt
 614 SUBROUTINE 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
 623 IMPLICIT 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)
 630 END SUBROUTINE c_esmc_basetimene
 631
 632 SUBROUTINE 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)
 641 END SUBROUTINE c_esmc_basetimeinteq
 642 SUBROUTINE 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)
 651 END SUBROUTINE c_esmc_basetimeintne
 652 SUBROUTINE 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)
 661 END SUBROUTINE c_esmc_basetimeintlt
 662 SUBROUTINE 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)
 671 END SUBROUTINE c_esmc_basetimeintgt
 672 SUBROUTINE 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)
 681 END SUBROUTINE c_esmc_basetimeintle
 682 SUBROUTINE 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)
 691 END SUBROUTINE c_esmc_basetimeintge
 692
 693 SUBROUTINE 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
 716 END SUBROUTINE compute_lcd
 717
 718 SUBROUTINE 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
 755 END SUBROUTINE simplify
 756
 757
 758 !$$$ this should be named "c_esmc_timesum" or something less misleading
 759 SUBROUTINE 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 )
 785 END SUBROUTINE c_esmc_basetimesum
 786
 787
 788 !$$$ this should be named "c_esmc_timedec" or something less misleading
 789 SUBROUTINE 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
 809 END SUBROUTINE c_esmc_basetimedec
 810
 811
 812 !$$$ this should be named "c_esmc_timediff" or something less misleading
 813 SUBROUTINE 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 )
 839 END 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.
 849 SUBROUTINE 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
 868 END 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.
 875 SUBROUTINE 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 )
 886 END SUBROUTINE fraction_to_string
 887
 888
 889 SUBROUTINE 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
 899 END SUBROUTINE print_a_time
 900
 901 SUBROUTINE 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
 911 END SUBROUTINE print_a_timeinterval
 912