PageRenderTime 42ms CodeModel.GetById 8ms RepoModel.GetById 1ms app.codeStats 0ms

/wrfv2_fire/external/esmf_time_f90/Meat.F90

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