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
   7 SUBROUTINE normalize_basetime( basetime )
   8   USE WRF_ESMF_BaseMod
   9   USE WRF_ESMF_BaseTimeMod
  10   IMPLICIT NONE
  11   TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime
  12   !BPR BEGIN
  13   INTEGER(ESMF_KIND_I8) :: Sn_simplified, Sd_simplified
  14   INTEGER :: primes_to_check
  15   !BPR END
  16
  17 !PRINT *,'DEBUG:  BEGIN normalize_basetime()'
  18   ! Consistency check...
  19   IF ( basetime%Sd < 0 ) THEN
  20     CALL wrf_error_fatal( &
  21       'normalize_basetime:  denominator of seconds cannot be negative' )
  22   ENDIF
  23   IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN
  24     CALL wrf_error_fatal( &
  25       'normalize_basetime:  denominator of seconds cannot be zero when numerator is non-zero' )
  26   ENDIF
  27   ! factor so abs(Sn) < Sd
  28   IF ( basetime%Sd > 0 ) THEN
  29     IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN
  30 !PRINT *,'DEBUG:  normalize_basetime() A1:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
  31       basetime%S = basetime%S + ( basetime%Sn / basetime%Sd )
  32       basetime%Sn = mod( basetime%Sn, basetime%Sd )
  33 !PRINT *,'DEBUG:  normalize_basetime() A2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
  34     ENDIF
  35     ! change sign of Sn if it does not match S
  36     IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN
  37 !PRINT *,'DEBUG:  normalize_basetime() B1:  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() B2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
  41     ENDIF
  42     IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN
  43 !PRINT *,'DEBUG:  normalize_basetime() C1:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
  44       basetime%S = basetime%S + 1_ESMF_KIND_I8
  45       basetime%Sn = basetime%Sn - basetime%Sd
  46 !PRINT *,'DEBUG:  normalize_basetime() C2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
  47     ENDIF
  48   ENDIF
  49
  50   !BPR BEGIN
  51   !Simplify the fraction -- otherwise the fraction can get needlessly complicated and
  52   !cause WRF to crash
  53   IF ( ( basetime%Sd > 0 ) .AND. (basetime%Sn > 0 ) ) THEN
  54     CALL simplify( basetime%Sn, basetime%Sd, Sn_simplified, Sd_simplified )
  55     basetime%Sn = Sn_simplified
  56     basetime%Sd = Sd_simplified
  57     !If the numerator and denominator are both larger than 10000, after simplification
  58     !using the first 9 primes, the chances increase that there is a common prime factor other
  59     !than the 9 searched for in the standard simplify
  60     !By only searching for more than 9 primes when the numerator and denominator are
  61     !large, we avoid the additional computational expense of checking additional primes
  62     !for a large number of cases
  63     IF ( ( basetime%Sd > 10000 ) .AND. (basetime%Sn > 10000 ) ) THEN
  64       primes_to_check = 62
  65       CALL simplify_numprimes( basetime%Sn, basetime%Sd, Sn_simplified, Sd_simplified, &
  66                                primes_to_check )
  67       basetime%Sn = Sn_simplified
  68       basetime%Sd = Sd_simplified
  69     ENDIF
  70   ENDIF
  71   !BPR END
  72
  73 !PRINT *,'DEBUG:  END normalize_basetime()'
  74 END SUBROUTINE normalize_basetime
  75
  76
  77
  78 ! A normalized time has time%basetime >= 0, time%basetime less than the current
  79 ! year expressed as a timeInterval, and time%YR can take any value
  80 SUBROUTINE normalize_time( time )
  81   USE WRF_ESMF_BaseMod
  82   USE WRF_ESMF_BaseTimeMod
  83   USE WRF_ESMF_TimeMod
  84   IMPLICIT NONE
  85   TYPE(ESMF_Time), INTENT(INOUT) :: time
  86   INTEGER(ESMF_KIND_I8) :: nsecondsinyear
  87   ! locals
  88   TYPE(ESMF_BaseTime) :: cmptime, zerotime
  89   INTEGER :: rc
  90   LOGICAL :: done
  91
  92   ! first, normalize basetime
  93   ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
  94   CALL normalize_basetime( time%basetime )
  95
  96 !$$$ add tests for these edge cases
  97
  98   ! next, underflow negative seconds into YEARS
  99   ! time%basetime must end up non-negative
 100 !$$$ push this down into ESMF_BaseTime constructor
 101   zerotime%S  = 0
 102   zerotime%Sn = 0
 103   zerotime%Sd = 0
 104   DO WHILE ( time%basetime < zerotime )
 105     time%YR = time%YR - 1
 106 !$$$ push this down into ESMF_BaseTime constructor
 107     cmptime%S  = nsecondsinyear( time%YR )
 108     cmptime%Sn = 0
 109     cmptime%Sd = 0
 110     time%basetime = time%basetime + cmptime
 111   ENDDO
 112
 113   ! next, overflow seconds into YEARS
 114   done = .FALSE.
 115   DO WHILE ( .NOT. done )
 116 !$$$ push this down into ESMF_BaseTime constructor
 117     cmptime%S  = nsecondsinyear( time%YR )
 118     cmptime%Sn = 0
 119     cmptime%Sd = 0
 120     IF ( time%basetime >= cmptime ) THEN
 121       time%basetime = time%basetime - cmptime
 122       time%YR = time%YR + 1
 123     ELSE
 124       done = .TRUE.
 125     ENDIF
 126   ENDDO
 127 END SUBROUTINE normalize_time
 128
 129
 130
 131 SUBROUTINE normalize_timeint( timeInt )
 132   USE WRF_ESMF_BaseTimeMod
 133   USE WRF_ESMF_TimeIntervalMod
 134   IMPLICIT NONE
 135   TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt
 136
 137   ! normalize basetime
 138   ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match
 139   ! YR and MM are ignored
 140   CALL normalize_basetime( timeInt%basetime )
 141 END SUBROUTINE normalize_timeint
 142
 143
 144
 145
 146 FUNCTION signnormtimeint ( timeInt )
 147   ! Compute the sign of a time interval.
 148   ! YR and MM fields are *IGNORED*.
 149   ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs.
 150   USE WRF_ESMF_BaseMod
 151   USE WRF_ESMF_BaseTimeMod
 152   USE WRF_ESMF_TimeIntervalMod
 153   IMPLICIT NONE
 154   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
 155   INTEGER :: signnormtimeint
 156   LOGICAL :: positive, negative
 157
 158   positive = .FALSE.
 159   negative = .FALSE.
 160   signnormtimeint = 0
 161   ! Note that Sd is required to be non-negative.  This is enforced in
 162   ! normalize_timeint().
 163   ! Note that Sn is required to be zero when Sd is zero.  This is enforced
 164   ! in normalize_timeint().
 165   IF ( ( timeInt%basetime%S > 0 ) .OR. &
 166        ( timeInt%basetime%Sn > 0 ) ) THEN
 167     positive = .TRUE.
 168   ENDIF
 169   IF ( ( timeInt%basetime%S < 0 ) .OR. &
 170        ( timeInt%basetime%Sn < 0 ) ) THEN
 171     negative = .TRUE.
 172   ENDIF
 173   IF ( positive .AND. negative ) THEN
 174     CALL wrf_error_fatal( &
 175       'signnormtimeint:  signs of fields cannot be mixed' )
 176   ELSE IF ( positive ) THEN
 177     signnormtimeint = 1
 178   ELSE IF ( negative ) THEN
 179     signnormtimeint = -1
 180   ENDIF
 181 END FUNCTION signnormtimeint
 182
 183
 184 ! Exits with error message if timeInt is not normalized.
 185 SUBROUTINE timeintchecknormalized( timeInt, msgstr )
 186   USE WRF_ESMF_TimeIntervalMod
 187   IMPLICIT NONE
 188   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt
 189   CHARACTER(LEN=*), INTENT(IN) :: msgstr
 190   ! locals
 191   CHARACTER(LEN=256) :: outstr
 192   IF ( ( timeInt%YR /= 0 ) ) THEN
 193     outstr = 'un-normalized TimeInterval not allowed:  '//TRIM(msgstr)
 194     CALL wrf_error_fatal( outstr )
 195   ENDIF
 196 END SUBROUTINE timeintchecknormalized
 197
 198
 199 ! added from share/module_date_time in WRF.
 200 FUNCTION nfeb ( year ) RESULT (num_days)
 201       ! Compute the number of days in February for the given year
 202       IMPLICIT NONE
 203       INTEGER :: year
 204       INTEGER :: num_days
 205 ! TBH:  TODO:  Replace this hack with run-time decision based on
 206 ! TBH:  TODO:  passed-in calendar.
 207 #ifdef NO_LEAP_CALENDAR
 208       num_days = 28 ! By default, February has 28 days ...
 209 #else
 210       num_days = 28 ! By default, February has 28 days ...
 211       IF (MOD(year,4).eq.0) THEN
 212          num_days = 29  ! But every four years, it has 29 days ...
 213          IF (MOD(year,100).eq.0) THEN
 214             num_days = 28  ! Except every 100 years, when it has 28 days ...
 215             IF (MOD(year,400).eq.0) THEN
 216                num_days = 29  ! Except every 400 years, when it has 29 days.
 217             END IF
 218          END IF
 219       END IF
 220 #endif
 221 END FUNCTION nfeb
 222
 223
 224
 225 FUNCTION ndaysinyear ( year ) RESULT (num_diy)
 226   ! Compute the number of days in the given year
 227   IMPLICIT NONE
 228   INTEGER, INTENT(IN) :: year
 229   INTEGER :: num_diy
 230   INTEGER :: nfeb
 231 #if defined MARS
 232   num_diy = 669
 233 #elif defined TITAN
 234   num_diy = 686
 235 #else
 236   IF ( nfeb( year ) .EQ. 29 ) THEN
 237     num_diy = 366
 238   ELSE
 239     num_diy = 365
 240   ENDIF
 241 #endif
 242 END FUNCTION ndaysinyear
 243
 244
 245
 246 FUNCTION nsecondsinyear ( year ) RESULT (numseconds)
 247   ! Compute the number of seconds in the given year
 248   USE WRF_ESMF_BaseMod
 249   IMPLICIT NONE
 250   INTEGER, INTENT(IN) :: year
 251   INTEGER(ESMF_KIND_I8) :: numseconds
 252   INTEGER :: ndaysinyear
 253   numseconds = SECONDS_PER_DAY * INT( ndaysinyear(year) , ESMF_KIND_I8 )
 254 END FUNCTION nsecondsinyear
 255
 256
 257
 258 SUBROUTINE initdaym
 259   USE WRF_ESMF_BaseMod
 260   USE WRF_ESMF_BaseTimeMod
 261   USE WRF_ESMF_CalendarMod, only : months_per_year, mday, daym, mdaycum, monthbdys, &
 262                                mdayleap, mdayleapcum, monthbdysleap, daymleap
 263   IMPLICIT NONE
 264   INTEGER i,j,m
 265   m = 1
 266   mdaycum(0) = 0
 267 !$$$ push this down into ESMF_BaseTime constructor
 268   monthbdys(0)%S  = 0
 269   monthbdys(0)%Sn = 0
 270   monthbdys(0)%Sd = 0
 271   DO i = 1,MONTHS_PER_YEAR
 272     DO j = 1,mday(i)
 273       daym(m) = i
 274       m = m + 1
 275     ENDDO
 276     mdaycum(i) = mdaycum(i-1) + mday(i)
 277 !$$$ push this down into ESMF_BaseTime constructor
 278     monthbdys(i)%S  = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 )
 279     monthbdys(i)%Sn = 0
 280     monthbdys(i)%Sd = 0
 281   ENDDO
 282   m = 1
 283   mdayleapcum(0) = 0
 284 !$$$ push this down into ESMF_BaseTime constructor
 285   monthbdysleap(0)%S  = 0
 286   monthbdysleap(0)%Sn = 0
 287   monthbdysleap(0)%Sd = 0
 288   DO i = 1,MONTHS_PER_YEAR
 289     DO j = 1,mdayleap(i)
 290       daymleap(m) = i
 291       m = m + 1
 292     ENDDO
 293     mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i)
 294 !$$$ push this down into ESMF_BaseTime constructor
 295     monthbdysleap(i)%S  = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 )
 296     monthbdysleap(i)%Sn = 0
 297     monthbdysleap(i)%Sd = 0
 298   ENDDO
 299 END SUBROUTINE initdaym
 300
 301
 302 !$$$ useful, but not used at the moment...
 303 SUBROUTINE compute_dayinyear(YR,MM,DD,dayinyear)
 304   use WRF_ESMF_CalendarMod, only : mday
 305 IMPLICIT NONE
 306       INTEGER, INTENT(IN)  :: YR,MM,DD   ! DD is day of month
 307       INTEGER, INTENT(OUT) :: dayinyear
 308       INTEGER i
 309       integer nfeb
 310
 311 #ifdef PLANET
 312       dayinyear = DD
 313 #else
 314       dayinyear = 0
 315       DO i = 1,MM-1
 316         if (i.eq.2) then
 317           dayinyear = dayinyear + nfeb(YR)
 318         else
 319           dayinyear = dayinyear + mday(i)
 320         endif
 321       ENDDO
 322       dayinyear = dayinyear + DD
 323 #endif
 324 END SUBROUTINE compute_dayinyear
 325
 326
 327
 328 SUBROUTINE timegetmonth( time, MM )
 329   USE WRF_ESMF_BaseMod
 330   USE WRF_ESMF_BaseTimeMod
 331   USE WRF_ESMF_TimeMod
 332   USE WRF_ESMF_CalendarMod, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap
 333   IMPLICIT NONE
 334   TYPE(ESMF_Time), INTENT(IN) :: time
 335   INTEGER, INTENT(OUT) :: MM
 336   ! locals
 337   INTEGER :: nfeb
 338   INTEGER :: i
 339 #if defined PLANET
 340   MM = 0
 341 #else
 342   MM = -1
 343   IF ( nfeb(time%YR) == 29 ) THEN
 344     DO i = 1,MONTHS_PER_YEAR
 345       IF ( ( time%basetime >= monthbdysleap(i-1) ) .AND. ( time%basetime < monthbdysleap(i) ) ) THEN
 346         MM = i
 347         EXIT
 348       ENDIF
 349     ENDDO
 350   ELSE
 351     DO i = 1,MONTHS_PER_YEAR
 352       IF ( ( time%basetime >= monthbdys(i-1) ) .AND. ( time%basetime < monthbdys(i) ) ) THEN
 353         MM = i
 354         EXIT
 355       ENDIF
 356     ENDDO
 357   ENDIF
 358 #endif
 359   IF ( MM == -1 ) THEN
 360     CALL wrf_error_fatal( 'timegetmonth:  could not extract month of year from time' )
 361   ENDIF
 362 END SUBROUTINE timegetmonth
 363
 364
 365 !$$$ may need to change dependencies in Makefile...
 366
 367 SUBROUTINE timegetdayofmonth( time, DD )
 368   USE WRF_ESMF_BaseMod
 369   USE WRF_ESMF_BaseTimeMod
 370   USE WRF_ESMF_TimeMod
 371   USE WRF_ESMF_CalendarMod, only : monthbdys, monthbdysleap
 372   IMPLICIT NONE
 373   TYPE(ESMF_Time), INTENT(IN) :: time
 374   INTEGER, INTENT(OUT) :: DD
 375   ! locals
 376   INTEGER :: nfeb
 377   INTEGER :: MM
 378   TYPE(ESMF_BaseTime) :: tmpbasetime
 379 #if defined PLANET
 380   tmpbasetime = time%basetime
 381 #else
 382   CALL timegetmonth( time, MM )
 383   IF ( nfeb(time%YR) == 29 ) THEN
 384     tmpbasetime = time%basetime - monthbdysleap(MM-1)
 385   ELSE
 386     tmpbasetime = time%basetime - monthbdys(MM-1)
 387   ENDIF
 388 #endif
 389   DD = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1
 390 END SUBROUTINE timegetdayofmonth
 391
 392
 393 ! Increment Time by number of seconds between start of year and start
 394 ! of month MM.
 395 ! 1 <= MM <= 12
 396 ! Time is NOT normalized.
 397 SUBROUTINE timeaddmonths( time, MM, ierr )
 398   USE WRF_ESMF_BaseMod
 399   USE WRF_ESMF_BaseTimeMod
 400   USE WRF_ESMF_TimeMod
 401   USE WRF_ESMF_CalendarMod, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap
 402   IMPLICIT NONE
 403   TYPE(ESMF_Time), INTENT(INOUT) :: time
 404   INTEGER, INTENT(IN) :: MM
 405   INTEGER, INTENT(OUT) :: ierr
 406   ! locals
 407   INTEGER :: nfeb
 408   ierr = ESMF_SUCCESS
 409 !  PRINT *,'DEBUG:  BEGIN timeaddmonths()'
 410 #if defined PLANET
 411 !  time%basetime = time%basetime
 412 #else
 413   IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN
 414     ierr = ESMF_FAILURE
 415   ELSE
 416     IF ( nfeb(time%YR) == 29 ) THEN
 417       time%basetime = time%basetime + monthbdysleap(MM-1)
 418     ELSE
 419       time%basetime = time%basetime + monthbdys(MM-1)
 420     ENDIF
 421   ENDIF
 422 #endif
 423 END SUBROUTINE timeaddmonths
 424
 425
 426 ! Increment Time by number of seconds in the current month.
 427 ! Time is NOT normalized.
 428 SUBROUTINE timeincmonth( time )
 429   USE WRF_ESMF_BaseMod
 430   USE WRF_ESMF_BaseTimeMod
 431   USE WRF_ESMF_TimeMod
 432   USE WRF_ESMF_CalendarMod, only : mday, mdayleap
 433   IMPLICIT NONE
 434   TYPE(ESMF_Time), INTENT(INOUT) :: time
 435   ! locals
 436   INTEGER :: nfeb
 437   INTEGER :: MM
 438 #if defined PLANET
 439 !    time%basetime%S = time%basetime%S
 440 #else
 441   CALL timegetmonth( time, MM )
 442   IF ( nfeb(time%YR) == 29 ) THEN
 443     time%basetime%S = time%basetime%S + &
 444       ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
 445   ELSE
 446     time%basetime%S = time%basetime%S + &
 447       ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
 448   ENDIF
 449 #endif
 450 END SUBROUTINE timeincmonth
 451
 452
 453
 454 ! Decrement Time by number of seconds in the previous month.
 455 ! Time is NOT normalized.
 456 SUBROUTINE timedecmonth( time )
 457   USE WRF_ESMF_BaseMod
 458   USE WRF_ESMF_BaseTimeMod
 459   USE WRF_ESMF_TimeMod
 460   USE WRF_ESMF_CalendarMod, only : mday, months_per_year, mdayleap
 461   IMPLICIT NONE
 462   TYPE(ESMF_Time), INTENT(INOUT) :: time
 463   ! locals
 464   INTEGER :: nfeb
 465   INTEGER :: MM
 466 #if defined PLANET
 467 !    time%basetime%S = time%basetime%S
 468 #else
 469   CALL timegetmonth( time, MM )  ! current month, 1-12
 470   ! find previous month
 471   MM = MM - 1
 472   IF ( MM == 0 ) THEN
 473     ! wrap around Jan -> Dec
 474     MM = MONTHS_PER_YEAR
 475   ENDIF
 476   IF ( nfeb(time%YR) == 29 ) THEN
 477     time%basetime%S = time%basetime%S - &
 478       ( INT( mdayleap(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
 479   ELSE
 480     time%basetime%S = time%basetime%S - &
 481       ( INT( mday(MM), ESMF_KIND_I8 ) * SECONDS_PER_DAY )
 482   ENDIF
 483 #endif
 484 END SUBROUTINE timedecmonth
 485
 486
 487
 488 ! spaceship operator for Times
 489 SUBROUTINE timecmp(time1, time2, retval )
 490   USE WRF_ESMF_BaseMod
 491   USE WRF_ESMF_BaseTimeMod
 492   USE WRF_ESMF_TimeMod
 493   IMPLICIT NONE
 494   INTEGER, INTENT(OUT) :: retval
 495 !
 496 ! !ARGUMENTS:
 497   TYPE(ESMF_Time), INTENT(IN) :: time1
 498   TYPE(ESMF_Time), INTENT(IN) :: time2
 499   IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF
 500   IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF
 501   CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, &
 502                time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, &
 503                retval )
 504 END SUBROUTINE timecmp
 505
 506
 507
 508 ! spaceship operator for TimeIntervals
 509 SUBROUTINE timeintcmp(timeint1, timeint2, retval )
 510   USE WRF_ESMF_BaseMod
 511   USE WRF_ESMF_BaseTimeMod
 512   USE WRF_ESMF_TimeIntervalMod
 513   IMPLICIT NONE
 514   INTEGER, INTENT(OUT) :: retval
 515 !
 516 ! !ARGUMENTS:
 517   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 518   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 519   CALL timeintchecknormalized( timeint1, 'timeintcmp arg1' )
 520   CALL timeintchecknormalized( timeint2, 'timeintcmp arg2' )
 521   CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, &
 522                timeint1%basetime%Sd,                      &
 523                timeint2%basetime%S, timeint2%basetime%Sn, &
 524                timeint2%basetime%Sd, retval )
 525 END SUBROUTINE timeintcmp
 526
 527
 528
 529 ! spaceship operator for seconds + Sn/Sd
 530 SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval )
 531   USE WRF_ESMF_BaseMod
 532   IMPLICIT NONE
 533   INTEGER, INTENT(OUT) :: retval
 534 !
 535 ! !ARGUMENTS:
 536   INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1
 537   INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2
 538 ! local
 539   INTEGER(ESMF_KIND_I8) :: lcd, n1, n2
 540
 541   n1 = Sn1
 542   n2 = Sn2
 543   if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then
 544     CALL compute_lcd( Sd1, Sd2, lcd )
 545     if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 )
 546     if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 )
 547   endif
 548
 549   if ( S1 .GT. S2 ) retval = 1
 550   if ( S1 .LT. S2 ) retval = -1
 551   IF ( S1 .EQ. S2 ) THEN
 552     IF (n1 .GT. n2) retval = 1
 553     IF (n1 .LT. n2) retval = -1
 554     IF (n1 .EQ. n2) retval = 0
 555   ENDIF
 556 END SUBROUTINE seccmp
 557
 558
 559 SUBROUTINE c_esmc_basetimeeq (time1, time2, outflag)
 560   USE WRF_ESMF_AlarmMod
 561   USE WRF_ESMF_BaseMod
 562   USE WRF_ESMF_BaseTimeMod
 563   USE WRF_ESMF_CalendarMod
 564   USE WRF_ESMF_ClockMod
 565   USE WRF_ESMF_FractionMod
 566   USE WRF_ESMF_TimeIntervalMod
 567   USE WRF_ESMF_TimeMod
 568 IMPLICIT NONE
 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. 0)
 575 END SUBROUTINE c_esmc_basetimeeq
 576 SUBROUTINE c_esmc_basetimege(time1, time2, outflag)
 577   USE WRF_ESMF_AlarmMod
 578   USE WRF_ESMF_BaseMod
 579   USE WRF_ESMF_BaseTimeMod
 580   USE WRF_ESMF_CalendarMod
 581   USE WRF_ESMF_ClockMod
 582   USE WRF_ESMF_FractionMod
 583   USE WRF_ESMF_TimeIntervalMod
 584   USE WRF_ESMF_TimeMod
 585       logical, intent(OUT) :: outflag
 586       type(ESMF_Time), intent(in) :: time1
 587       type(ESMF_Time), intent(in) :: time2
 588       integer res
 589       CALL timecmp(time1,time2,res)
 590       outflag = (res .EQ. 1 .OR. res .EQ. 0)
 591 END SUBROUTINE c_esmc_basetimege
 592 SUBROUTINE c_esmc_basetimegt(time1, time2, outflag)
 593   USE WRF_ESMF_AlarmMod
 594   USE WRF_ESMF_BaseMod
 595   USE WRF_ESMF_BaseTimeMod
 596   USE WRF_ESMF_CalendarMod
 597   USE WRF_ESMF_ClockMod
 598   USE WRF_ESMF_FractionMod
 599   USE WRF_ESMF_TimeIntervalMod
 600   USE WRF_ESMF_TimeMod
 601 IMPLICIT NONE
 602       logical, intent(OUT) :: outflag
 603       type(ESMF_Time), intent(in) :: time1
 604       type(ESMF_Time), intent(in) :: time2
 605       integer res
 606       CALL timecmp(time1,time2,res)
 607       outflag = (res .EQ. 1)
 608 END SUBROUTINE c_esmc_basetimegt
 609 SUBROUTINE c_esmc_basetimele(time1, time2, outflag)
 610   USE WRF_ESMF_AlarmMod
 611   USE WRF_ESMF_BaseMod
 612   USE WRF_ESMF_BaseTimeMod
 613   USE WRF_ESMF_CalendarMod
 614   USE WRF_ESMF_ClockMod
 615   USE WRF_ESMF_FractionMod
 616   USE WRF_ESMF_TimeIntervalMod
 617   USE WRF_ESMF_TimeMod
 618 IMPLICIT NONE
 619       logical, intent(OUT) :: outflag
 620       type(ESMF_Time), intent(in) :: time1
 621       type(ESMF_Time), intent(in) :: time2
 622       integer res
 623       CALL timecmp(time1,time2,res)
 624       outflag = (res .EQ. -1 .OR. res .EQ. 0)
 625 END SUBROUTINE c_esmc_basetimele
 626 SUBROUTINE c_esmc_basetimelt(time1, time2, outflag)
 627   USE WRF_ESMF_AlarmMod
 628   USE WRF_ESMF_BaseMod
 629   USE WRF_ESMF_BaseTimeMod
 630   USE WRF_ESMF_CalendarMod
 631   USE WRF_ESMF_ClockMod
 632   USE WRF_ESMF_FractionMod
 633   USE WRF_ESMF_TimeIntervalMod
 634   USE WRF_ESMF_TimeMod
 635 IMPLICIT NONE
 636       logical, intent(OUT) :: outflag
 637       type(ESMF_Time), intent(in) :: time1
 638       type(ESMF_Time), intent(in) :: time2
 639       integer res
 640       CALL timecmp(time1,time2,res)
 641       outflag = (res .EQ. -1)
 642 END SUBROUTINE c_esmc_basetimelt
 643 SUBROUTINE c_esmc_basetimene(time1, time2, outflag)
 644   USE WRF_ESMF_AlarmMod
 645   USE WRF_ESMF_BaseMod
 646   USE WRF_ESMF_BaseTimeMod
 647   USE WRF_ESMF_CalendarMod
 648   USE WRF_ESMF_ClockMod
 649   USE WRF_ESMF_FractionMod
 650   USE WRF_ESMF_TimeIntervalMod
 651   USE WRF_ESMF_TimeMod
 652 IMPLICIT NONE
 653       logical, intent(OUT) :: outflag
 654       type(ESMF_Time), intent(in) :: time1
 655       type(ESMF_Time), intent(in) :: time2
 656       integer res
 657       CALL timecmp(time1,time2,res)
 658       outflag = (res .NE. 0)
 659 END SUBROUTINE c_esmc_basetimene
 660
 661 SUBROUTINE c_esmc_basetimeinteq(timeint1, timeint2, outflag)
 662   USE WRF_ESMF_TimeIntervalMod
 663   IMPLICIT NONE
 664   LOGICAL, INTENT(OUT) :: outflag
 665   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 666   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 667   INTEGER :: res
 668   CALL timeintcmp(timeint1,timeint2,res)
 669   outflag = (res .EQ. 0)
 670 END SUBROUTINE c_esmc_basetimeinteq
 671 SUBROUTINE c_esmc_basetimeintne(timeint1, timeint2, outflag)
 672   USE WRF_ESMF_TimeIntervalMod
 673   IMPLICIT NONE
 674   LOGICAL, INTENT(OUT) :: outflag
 675   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 676   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 677   INTEGER :: res
 678   CALL timeintcmp(timeint1,timeint2,res)
 679   outflag = (res .NE. 0)
 680 END SUBROUTINE c_esmc_basetimeintne
 681 SUBROUTINE c_esmc_basetimeintlt(timeint1, timeint2, outflag)
 682   USE WRF_ESMF_TimeIntervalMod
 683   IMPLICIT NONE
 684   LOGICAL, INTENT(OUT) :: outflag
 685   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 686   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 687   INTEGER :: res
 688   CALL timeintcmp(timeint1,timeint2,res)
 689   outflag = (res .LT. 0)
 690 END SUBROUTINE c_esmc_basetimeintlt
 691 SUBROUTINE c_esmc_basetimeintgt(timeint1, timeint2, outflag)
 692   USE WRF_ESMF_TimeIntervalMod
 693   IMPLICIT NONE
 694   LOGICAL, INTENT(OUT) :: outflag
 695   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 696   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 697   INTEGER :: res
 698   CALL timeintcmp(timeint1,timeint2,res)
 699   outflag = (res .GT. 0)
 700 END SUBROUTINE c_esmc_basetimeintgt
 701 SUBROUTINE c_esmc_basetimeintle(timeint1, timeint2, outflag)
 702   USE WRF_ESMF_TimeIntervalMod
 703   IMPLICIT NONE
 704   LOGICAL, INTENT(OUT) :: outflag
 705   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 706   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 707   INTEGER :: res
 708   CALL timeintcmp(timeint1,timeint2,res)
 709   outflag = (res .LE. 0)
 710 END SUBROUTINE c_esmc_basetimeintle
 711 SUBROUTINE c_esmc_basetimeintge(timeint1, timeint2, outflag)
 712   USE WRF_ESMF_TimeIntervalMod
 713   IMPLICIT NONE
 714   LOGICAL, INTENT(OUT) :: outflag
 715   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1
 716   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2
 717   INTEGER :: res
 718   CALL timeintcmp(timeint1,timeint2,res)
 719   outflag = (res .GE. 0)
 720 END SUBROUTINE c_esmc_basetimeintge
 721
 722 SUBROUTINE compute_lcd( e1, e2, lcd )
 723   USE WRF_ESMF_BaseMod
 724       IMPLICIT NONE
 725       INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2
 726       INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd
 727       INTEGER, PARAMETER ::  nprimes = 9
 728       INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
 729       INTEGER i
 730       INTEGER(ESMF_KIND_I8) d1, d2, p
 731
 732       d1 = e1 ; d2 = e2
 733       IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF
 734       IF ( d1 .EQ. 0 ) d1 = d2
 735       IF ( d2 .EQ. 0 ) d2 = d1
 736       IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF
 737       lcd = d1 * d2
 738       DO i = 1, nprimes
 739         p = primes(i)
 740         DO WHILE (lcd/p .NE. 0 .AND. &
 741           mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0)
 742           lcd = lcd / p
 743         END DO
 744       ENDDO
 745 END SUBROUTINE compute_lcd
 746
 747 SUBROUTINE simplify( ni, di, no, do )
 748   USE WRF_ESMF_BaseMod
 749     IMPLICIT NONE
 750     INTEGER(ESMF_KIND_I8), INTENT(IN)  :: ni, di
 751     INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
 752     INTEGER, PARAMETER ::  nprimes = 9
 753     INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/)
 754     INTEGER(ESMF_KIND_I8) :: pr, d, n
 755     INTEGER :: np
 756     LOGICAL keepgoing
 757     IF ( ni .EQ. 0 ) THEN
 758       do = 1
 759       no = 0
 760       RETURN
 761     ENDIF
 762     IF ( mod( di , ni ) .EQ. 0 ) THEN
 763       do = di / ni
 764       no = 1
 765       RETURN
 766     ENDIF
 767     d = di
 768     n = ni
 769     DO np = 1, nprimes
 770       pr = primes(np)
 771       keepgoing = .TRUE.
 772       DO WHILE ( keepgoing )
 773         keepgoing = .FALSE.
 774         IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
 775           d = d / pr
 776           n = n / pr
 777           keepgoing = .TRUE.
 778         ENDIF
 779       ENDDO
 780     ENDDO
 781     do = d
 782     no = n
 783     RETURN
 784 END SUBROUTINE simplify
 785
 786 !BPR BEGIN
 787 ! Same as simplify above, but allows user to choose the number of primes to check
 788 SUBROUTINE simplify_numprimes( ni, di, no, do, num_primes_to_check )
 789   USE WRF_ESMF_BaseMod
 790     IMPLICIT NONE
 791     INTEGER(ESMF_KIND_I8), INTENT(IN)  :: ni, di
 792     INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
 793     INTEGER, INTENT(IN) :: num_primes_to_check !Number of primes to check
 794     INTEGER, PARAMETER ::  nprimes = 62
 795     INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,&
 796      19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,&
 797      137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,&
 798      251,257,263,269,271,277,281,283,293/)
 799     INTEGER(ESMF_KIND_I8) :: pr, d, n
 800     INTEGER :: np
 801     LOGICAL keepgoing
 802     INTEGER :: num_primes_to_check_final !Number of primes to check after being limited to max
 803                                          !available number of primes
 804
 805     ! If the user chooses to check more primes than are currently specified in the subroutine
 806     ! then use the maximum number of primes currently specified
 807     num_primes_to_check_final = min(num_primes_to_check, nprimes)
 808
 809     IF ( ni .EQ. 0 ) THEN
 810       do = 1
 811       no = 0
 812       RETURN
 813     ENDIF
 814     IF ( mod( di , ni ) .EQ. 0 ) THEN
 815       do = di / ni
 816       no = 1
 817       RETURN
 818     ENDIF
 819     d = di
 820     n = ni
 821     DO np = 1, num_primes_to_check_final
 822       pr = primes(np)
 823       keepgoing = .TRUE.
 824       DO WHILE ( keepgoing )
 825         keepgoing = .FALSE.
 826         IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
 827           d = d / pr
 828           n = n / pr
 829           keepgoing = .TRUE.
 830         ENDIF
 831       ENDDO
 832     ENDDO
 833     do = d
 834     no = n
 835     RETURN
 836 END SUBROUTINE simplify_numprimes
 837 !BPR END
 838
 839
 840 !$$$ this should be named "c_esmc_timesum" or something less misleading
 841 SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
 842   USE WRF_ESMF_BaseMod
 843   USE WRF_ESMF_BaseTimeMod
 844   USE WRF_ESMF_TimeIntervalMod
 845   USE WRF_ESMF_TimeMod
 846   IMPLICIT NONE
 847   TYPE(ESMF_Time), INTENT(IN) :: time1
 848   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
 849   TYPE(ESMF_Time), INTENT(INOUT) :: timeOut
 850   ! locals
 851   INTEGER :: m
 852   timeOut = time1
 853   timeOut%basetime = timeOut%basetime + timeinterval%basetime
 854 #if 0
 855 !jm Month has no meaning for a timeinterval; removed 20100319
 856 #if defined PLANET
 857   ! Do nothing...
 858 #else
 859  DO m = 1, abs(timeinterval%MM)
 860     IF ( timeinterval%MM > 0 ) THEN
 861       CALL timeincmonth( timeOut )
 862     ELSE
 863       CALL timedecmonth( timeOut )
 864     ENDIF
 865   ENDDO
 866 #endif
 867 #endif
 868   timeOut%YR = timeOut%YR + timeinterval%YR
 869   CALL normalize_time( timeOut )
 870 END SUBROUTINE c_esmc_basetimesum
 871
 872
 873 !$$$ this should be named "c_esmc_timedec" or something less misleading
 874 SUBROUTINE c_esmc_basetimedec( time1, timeinterval, timeOut )
 875   USE WRF_ESMF_BaseMod
 876   USE WRF_ESMF_BaseTimeMod
 877   USE WRF_ESMF_TimeIntervalMod
 878   USE WRF_ESMF_TimeMod
 879   IMPLICIT NONE
 880   TYPE(ESMF_Time), INTENT(IN) :: time1
 881   TYPE(ESMF_TimeInterval), INTENT(IN) :: timeinterval
 882   TYPE(ESMF_Time), INTENT(OUT) :: timeOut
 883   ! locals
 884   TYPE (ESMF_TimeInterval)  :: neginterval
 885   neginterval = timeinterval
 886 !$$$push this down into a unary negation operator on TimeInterval
 887   neginterval%basetime%S = -neginterval%basetime%S
 888   neginterval%basetime%Sn = -neginterval%basetime%Sn
 889   neginterval%YR = -neginterval%YR
 890 #if 0
 891 !jm month has no meaning for an interval; removed 20100319
 892 #ifndef PLANET
 893   neginterval%MM = -neginterval%MM
 894 #endif
 895 #endif
 896   timeOut = time1 + neginterval
 897 END SUBROUTINE c_esmc_basetimedec
 898
 899
 900 !$$$ this should be named "c_esmc_timediff" or something less misleading
 901 SUBROUTINE c_esmc_basetimediff( time1, time2, timeIntOut )
 902   USE WRF_ESMF_BaseMod
 903   USE WRF_ESMF_BaseTimeMod
 904   USE WRF_ESMF_TimeIntervalMod
 905   USE WRF_ESMF_TimeMod
 906   IMPLICIT NONE
 907   TYPE(ESMF_Time), INTENT(IN) :: time1
 908   TYPE(ESMF_Time), INTENT(IN) :: time2
 909   TYPE(ESMF_TimeInterval), INTENT(OUT) :: timeIntOut
 910   ! locals
 911   INTEGER(ESMF_KIND_I8) :: nsecondsinyear
 912   INTEGER :: yr
 913   CALL ESMF_TimeIntervalSet( timeIntOut )
 914   timeIntOut%basetime = time1%basetime - time2%basetime
 915   ! convert difference in years to basetime...
 916   IF ( time1%YR > time2%YR ) THEN
 917     DO yr = time2%YR, ( time1%YR - 1 )
 918       timeIntOut%basetime%S = timeIntOut%basetime%S + nsecondsinyear( yr )
 919     ENDDO
 920   ELSE IF ( time2%YR > time1%YR ) THEN
 921     DO yr = time1%YR, ( time2%YR - 1 )
 922       timeIntOut%basetime%S = timeIntOut%basetime%S - nsecondsinyear( yr )
 923     ENDDO
 924   ENDIF
 925 !$$$ add tests for multi-year differences
 926   CALL normalize_timeint( timeIntOut )
 927 END SUBROUTINE c_esmc_basetimediff
 928
 929
 930 ! some extra wrf stuff
 931
 932
 933 ! Convert fraction to string with leading sign.
 934 ! If fraction simplifies to a whole number or if
 935 ! denominator is zero, return empty string.
 936 ! INTEGER*8 interface.
 937 SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
 938   USE WRF_ESMF_BaseMod
 939   IMPLICIT NONE
 940   INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
 941   INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
 942   CHARACTER (LEN=*), INTENT(OUT) :: frac_str
 943   IF ( denominator > 0 ) THEN
 944     IF ( mod( numerator, denominator ) /= 0 ) THEN
 945       IF ( numerator > 0 ) THEN
 946         WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
 947       ELSE   ! numerator < 0
 948         WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
 949       ENDIF
 950     ELSE   ! includes numerator == 0 case
 951       frac_str = ''
 952     ENDIF
 953   ELSE   ! no-fraction case
 954     frac_str = ''
 955   ENDIF
 956 END SUBROUTINE fraction_to_stringi8
 957
 958
 959 ! Convert fraction to string with leading sign.
 960 ! If fraction simplifies to a whole number or if
 961 ! denominator is zero, return empty string.
 962 ! INTEGER interface.
 963 SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
 964   USE WRF_ESMF_BaseMod
 965   IMPLICIT NONE
 966   INTEGER, INTENT(IN) :: numerator
 967   INTEGER, INTENT(IN) :: denominator
 968   CHARACTER (LEN=*), INTENT(OUT) :: frac_str
 969   ! locals
 970   INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
 971   numerator_i8 = INT( numerator, ESMF_KIND_I8 )
 972   denominator_i8 = INT( denominator, ESMF_KIND_I8 )
 973   CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
 974 END SUBROUTINE fraction_to_string
 975
 976
 977 SUBROUTINE print_a_time( time )
 978    use WRF_ESMF_BaseMod
 979    use WRF_ESMF_TimeMod
 980    IMPLICIT NONE
 981    type(ESMF_Time) time
 982    character*128 :: s
 983    integer rc
 984    CALL ESMF_TimeGet( time, timeString=s, rc=rc )
 985    print *,'Print a time|',TRIM(s),'|'
 986    return
 987 END SUBROUTINE print_a_time
 988
 989 SUBROUTINE print_a_timeinterval( time )
 990    use WRF_ESMF_BaseMod
 991    use WRF_ESMF_TimeIntervalMod
 992    IMPLICIT NONE
 993    type(ESMF_TimeInterval) time
 994    character*128 :: s
 995    integer rc
 996    CALL ESMFold_TimeIntervalGetString( time, s, rc )
 997    print *,'Print a time interval|',TRIM(s),'|'
 998    return
 999 END SUBROUTINE print_a_timeinterval
1000