2 ! "module_esmf_extensions" is responsible for yet-to-be-implemented ESMF
3 ! features used by the io_esmf package. Once ESMF development is complete,
4 ! this module may be removed.
6 ! NOTE for implementation of ESMF_*GetCurrent():
8 ! This implementation uses interfaces that pass Fortran POINTERs around
9 ! to avoid forcing use of overloaded assignment operators for shallow
10 ! copies. The goal of this approach is to be as insulated as possible
11 ! from ESMF object implementations. This avoids having to explicitly
12 ! copy-in *AND* copy-out through the standard component init(), run(),
13 ! and final() interfaces just to attach references to ESMF objects to
14 ! other objects. The explicit CICO *might* be required if we
15 ! instead attached shallow copies of the objects to other objects!
16 ! "Might" means it is not required now because ESMF objects are
17 ! implemented as simple pointers. However, Nancy Collins says that
18 ! the ESMF core team plans to add more state on the Fortran side of the
19 ! ESMF objects, so copy-out will eventually be required. Thus we use
20 ! POINTERs to attach references, as in other languages. Why ESMF
21 ! component interfaces aren't passing POINTERs to Fortran objects is
25 MODULE module_esmf_extensions
36 ! Data for ESMF_*GetCurrent()
37 ! These flags are set to .TRUE. iff current objects are valid.
38 LOGICAL, SAVE :: current_clock_valid = .FALSE.
39 TYPE(ESMF_Clock), POINTER :: current_clock
40 LOGICAL, SAVE :: current_importstate_valid = .FALSE.
41 TYPE(ESMF_State), POINTER :: current_importstate
42 LOGICAL, SAVE :: current_exportstate_valid = .FALSE.
43 TYPE(ESMF_State), POINTER :: current_exportstate
44 LOGICAL, SAVE :: current_gridcomp_valid = .FALSE.
45 TYPE(ESMF_GridComp), POINTER :: current_gridcomp
47 ! Flag for "is-initialized" inquiry
48 ! NOTE: esmf_is_initialized is not reset to .FALSE. when ESMF_Finalize is called
49 LOGICAL, SAVE :: esmf_is_initialized = .FALSE.
53 ! These convenience interfaces have been proposed to the ESMF core team.
54 ! "get current" variants
55 PUBLIC ESMF_ClockGetCurrent
56 PUBLIC ESMF_ImportStateGetCurrent
57 PUBLIC ESMF_ExportStateGetCurrent
58 PUBLIC ESMF_GridCompGetCurrent
59 ! "is-initialized" inquiry
60 PUBLIC WRFU_IsInitialized
62 ! extensions to standard ESMF interfaces
63 ! these extensions conform to documented plans for ESMF extensions
64 ! they should be removed as ESMF implementations are released
67 ! public routines to be replaced by ESMF internal implementations
68 ! These interfaces will not be public because ESMF will always be able
69 ! to call them in the right places without user intervention.
70 ! "get current" variants
71 PUBLIC ESMF_ClockSetCurrent
72 PUBLIC ESMF_ImportStateSetCurrent
73 PUBLIC ESMF_ExportStateSetCurrent
74 PUBLIC ESMF_GridCompSetCurrent
75 PUBLIC ESMF_SetCurrent
76 ! "is-initialized" inquiry
77 PUBLIC ESMF_SetInitialized
79 !!!!!!!!! added 20051012, JM
80 ! Need to request that this interface be added...
81 PUBLIC WRFU_TimeIntervalDIVQuot
83 ! duplicated routines from esmf_time_f90
84 ! move these to a common shared location later...
85 PUBLIC fraction_to_string
87 ! hack for bug in PGI 5.1-x
91 ! convenience function
92 PUBLIC ESMF_TimeIntervalIsPositive
97 ! Add "is initialized" behavior to ESMF interface
98 FUNCTION WRFU_IsInitialized()
99 LOGICAL WRFU_IsInitialized
100 WRFU_IsInitialized = esmf_is_initialized
101 END FUNCTION WRFU_IsInitialized
103 ! Add "is initialized" behavior to ESMF interface
104 ! This interface will go away as it will be done inside ESMF_Initialize().
105 SUBROUTINE ESMF_SetInitialized()
106 esmf_is_initialized = .TRUE.
107 END SUBROUTINE ESMF_SetInitialized
111 ! -------------------------- ESMF-public method -------------------------------
113 ! !IROUTINE: ESMF_ClockGetCurrent - Get current ESMF_Clock
115 SUBROUTINE ESMF_ClockGetCurrent(clock, rc)
117 TYPE(ESMF_Clock), POINTER :: clock
118 INTEGER, INTENT(OUT), OPTIONAL :: rc
121 ! Get the {\tt ESMF\_Clock} object of the current execution context.
124 ! \begin{description}
126 ! Upon return this holds the {\tt ESMF\_Clock} object of the current context.
128 ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
132 ! !REQUIREMENTS: SSSn.n, GGGn.n
133 !------------------------------------------------------------------------------
134 ! Assume failure until success
135 IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
136 IF ( current_clock_valid ) THEN
137 clock => current_clock
138 IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
140 END SUBROUTINE ESMF_ClockGetCurrent
141 !------------------------------------------------------------------------------
145 ! -------------------------- ESMF-public method -------------------------------
147 ! !IROUTINE: ESMF_ImportStateGetCurrent - Get current import ESMF_State
149 SUBROUTINE ESMF_ImportStateGetCurrent(importstate, rc)
151 TYPE(ESMF_State), POINTER :: importstate
152 INTEGER, INTENT(OUT), OPTIONAL :: rc
155 ! Get the import {\tt ESMF\_State} object of the current execution context.
158 ! \begin{description}
160 ! Upon return this holds the import {\tt ESMF\_State} object of the current context.
162 ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
166 ! !REQUIREMENTS: SSSn.n, GGGn.n
167 !------------------------------------------------------------------------------
168 ! Assume failure until success
169 IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
170 IF ( current_importstate_valid ) THEN
171 importstate => current_importstate
172 IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
174 END SUBROUTINE ESMF_ImportStateGetCurrent
175 !------------------------------------------------------------------------------
179 ! -------------------------- ESMF-public method -------------------------------
181 ! !IROUTINE: ESMF_ExportStateGetCurrent - Get current export ESMF_State
183 SUBROUTINE ESMF_ExportStateGetCurrent(exportstate, rc)
185 TYPE(ESMF_State), POINTER :: exportstate
186 INTEGER, INTENT(OUT), OPTIONAL :: rc
189 ! Get the export {\tt ESMF\_State} object of the current execution context.
192 ! \begin{description}
194 ! Upon return this holds the export {\tt ESMF\_State} object of the current context.
196 ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
200 ! !REQUIREMENTS: SSSn.n, GGGn.n
201 !------------------------------------------------------------------------------
202 ! Assume failure until success
203 IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
204 IF ( current_exportstate_valid ) THEN
205 exportstate => current_exportstate
206 IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
208 END SUBROUTINE ESMF_ExportStateGetCurrent
209 !------------------------------------------------------------------------------
213 ! -------------------------- ESMF-public method -------------------------------
215 ! !IROUTINE: ESMF_GridCompGetCurrent - Get current ESMF_GridComp
217 SUBROUTINE ESMF_GridCompGetCurrent(gridcomp, rc)
219 TYPE(ESMF_GridComp), POINTER :: gridcomp
220 INTEGER, INTENT(OUT), OPTIONAL :: rc
223 ! Get the {\tt ESMF\_GridComp} object of the current execution context.
226 ! \begin{description}
228 ! Upon return this holds the {\tt ESMF\_GridComp} object of the current context.
230 ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
234 ! !REQUIREMENTS: SSSn.n, GGGn.n
235 !------------------------------------------------------------------------------
236 ! Assume failure until success
237 IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
238 IF ( current_gridcomp_valid ) THEN
239 gridcomp => current_gridcomp
240 IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
242 END SUBROUTINE ESMF_GridCompGetCurrent
243 !------------------------------------------------------------------------------
248 ! Temporary method, to be replaced by ESMF internal implementation
249 ! Sets the current ESMF_Clock to clock.
250 SUBROUTINE ESMF_ClockSetCurrent(clock)
251 TYPE(ESMF_Clock), POINTER :: clock
252 current_clock => clock
253 current_clock_valid = .TRUE.
254 END SUBROUTINE ESMF_ClockSetCurrent
255 !------------------------------------------------------------------------------
258 ! Temporary method, to be replaced by ESMF internal implementation
259 ! Sets the current import ESMF_State to importstate.
260 SUBROUTINE ESMF_ImportStateSetCurrent(importstate)
261 TYPE(ESMF_State), POINTER :: importstate
262 current_importstate => importstate
263 current_importstate_valid = .TRUE.
264 END SUBROUTINE ESMF_ImportStateSetCurrent
265 !------------------------------------------------------------------------------
268 ! Temporary method, to be replaced by ESMF internal implementation
269 ! Sets the current export ESMF_State to exportstate.
270 SUBROUTINE ESMF_ExportStateSetCurrent(exportstate)
271 TYPE(ESMF_State), POINTER :: exportstate
272 current_exportstate => exportstate
273 current_exportstate_valid = .TRUE.
274 END SUBROUTINE ESMF_ExportStateSetCurrent
275 !------------------------------------------------------------------------------
278 ! Temporary method, to be replaced by ESMF internal implementation
279 ! Sets the current ESMF_GridComp to gridcomp.
280 SUBROUTINE ESMF_GridCompSetCurrent(gridcomp)
281 TYPE(ESMF_GridComp), POINTER :: gridcomp
282 current_gridcomp => gridcomp
283 current_gridcomp_valid = .TRUE.
284 END SUBROUTINE ESMF_GridCompSetCurrent
285 !------------------------------------------------------------------------------
288 ! Temporary method, to be replaced by ESMF internal implementation
289 ! Convenience interface to set everything at once...
290 ! This routine sets the current ESMF_GridComp, import and export
291 ! ESMF_States, and the current ESMF_Clock.
292 ! NOTE: It will be possible to remove this routine once ESMF supports
293 ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(),
294 ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent().
295 SUBROUTINE ESMF_SetCurrent( gcomp, importState, exportState, clock )
296 TYPE(ESMF_GridComp), OPTIONAL, POINTER :: gcomp
297 TYPE(ESMF_State), OPTIONAL, POINTER :: importState
298 TYPE(ESMF_State), OPTIONAL, POINTER :: exportState
299 TYPE(ESMF_Clock), OPTIONAL, POINTER :: clock
300 IF ( PRESENT( gcomp ) ) THEN
301 CALL ESMF_GridCompSetCurrent( gcomp )
302 CALL ESMF_ImportStateSetCurrent( importState )
303 CALL ESMF_ExportStateSetCurrent( exportState )
304 CALL ESMF_ClockSetCurrent( clock )
306 END SUBROUTINE ESMF_SetCurrent
307 !------------------------------------------------------------------------------
311 ! begin hack for bug in PGI 5.1-x
312 function ESMF_TimeLE(time1, time2)
313 logical :: ESMF_TimeLE
314 type(ESMF_Time), intent(in) :: time1
315 type(ESMF_Time), intent(in) :: time2
316 ESMF_TimeLE = (time1.LE.time2)
317 end function ESMF_TimeLE
318 function ESMF_TimeGE(time1, time2)
319 logical :: ESMF_TimeGE
320 type(ESMF_Time), intent(in) :: time1
321 type(ESMF_Time), intent(in) :: time2
322 ESMF_TimeGE = (time1.GE.time2)
323 end function ESMF_TimeGE
324 ! end hack for bug in PGI 5.1-x
326 ! convenience function
327 function ESMF_TimeIntervalIsPositive(timeinterval)
328 logical :: ESMF_TimeIntervalIsPositive
329 type(ESMF_TimeInterval), intent(in) :: timeinterval
330 type(ESMF_TimeInterval) :: zerotimeint
332 CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint )
333 ESMF_TimeIntervalIsPositive = (timeinterval .GT. zerotimeint)
334 end function ESMF_TimeIntervalIsPositive
339 ! Note: this implementation is largely duplicated from external/esmf_time_f90
340 !!!!!!!!!!!!!!!!!! added jm 20051012
341 ! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder
342 function WRFU_TimeIntervalDIVQuot(timeinterval1, timeinterval2)
345 INTEGER :: WRFU_TimeIntervalDIVQuot
348 type(ESMF_TimeInterval), intent(in) :: timeinterval1
349 type(ESMF_TimeInterval), intent(in) :: timeinterval2
352 INTEGER :: retval, isgn, rc
353 type(ESMF_TimeInterval) :: zero, i1,i2
356 ! Returns timeinterval1 divided by timeinterval2 as a fraction quotient.
359 ! \begin{description}
360 ! \item[timeinterval1]
362 ! \item[timeinterval2]
369 call ESMF_TimeIntervalSet( zero, rc=rc )
373 if ( i1 .LT. zero ) then
377 if ( i2 .LT. zero ) then
381 ! repeated subtraction
383 DO WHILE ( i1 .GE. i2 )
387 retval = retval * isgn
389 WRFU_TimeIntervalDIVQuot = retval
391 end function WRFU_TimeIntervalDIVQuot
396 ! implementations of extensions to standard ESMF interfaces
397 ! these extensions conform to documented plans for ESMF extensions
398 ! they should be removed as ESMF implementations are released
400 ! extend ESMF_TimeGet() to make dayOfYear_r8 work...
401 subroutine WRFU_TimeGet(time, yy, yy_i8, &
407 d_r8, h_r8, m_r8, s_r8, &
408 ms_r8, us_r8, ns_r8, &
410 ! 5.2.0r calendar, calendarType, timeZone, &
411 calendar, timeZone, &
412 timeString, timeStringISOFrac, &
413 dayOfWeek, midMonth, &
414 dayOfYear, dayOfYear_r8, &
416 type(ESMF_Time), intent(inout) :: time
417 integer(ESMF_KIND_I4), intent(out), optional :: yy
418 integer(ESMF_KIND_I8), intent(out), optional :: yy_i8
419 integer, intent(out), optional :: mm
420 integer, intent(out), optional :: dd
421 integer(ESMF_KIND_I4), intent(out), optional :: d
422 integer(ESMF_KIND_I8), intent(out), optional :: d_i8
423 integer(ESMF_KIND_I4), intent(out), optional :: h
424 integer(ESMF_KIND_I4), intent(out), optional :: m
425 integer(ESMF_KIND_I4), intent(out), optional :: s
426 integer(ESMF_KIND_I8), intent(out), optional :: s_i8
427 integer(ESMF_KIND_I4), intent(out), optional :: ms
428 integer(ESMF_KIND_I4), intent(out), optional :: us
429 integer(ESMF_KIND_I4), intent(out), optional :: ns
430 real(ESMF_KIND_R8), intent(out), optional :: d_r8 ! not implemented
431 real(ESMF_KIND_R8), intent(out), optional :: h_r8 ! not implemented
432 real(ESMF_KIND_R8), intent(out), optional :: m_r8 ! not implemented
433 real(ESMF_KIND_R8), intent(out), optional :: s_r8 ! not implemented
434 real(ESMF_KIND_R8), intent(out), optional :: ms_r8 ! not implemented
435 real(ESMF_KIND_R8), intent(out), optional :: us_r8 ! not implemented
436 real(ESMF_KIND_R8), intent(out), optional :: ns_r8 ! not implemented
437 integer(ESMF_KIND_I4), intent(out), optional :: sN
438 integer(ESMF_KIND_I4), intent(out), optional :: sD
439 type(ESMF_Calendar), intent(out), optional :: calendar
440 ! 5.2.0r type(ESMF_CalendarType), intent(out), optional :: calendarType
441 integer, intent(out), optional :: timeZone
442 character (len=*), intent(out), optional :: timeString
443 character (len=*), intent(out), optional :: timeStringISOFrac
444 integer, intent(out), optional :: dayOfWeek
445 type(ESMF_Time), intent(out), optional :: midMonth
446 integer(ESMF_KIND_I4), intent(out), optional :: dayOfYear
447 real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8 ! NOW implemented
448 type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl
449 integer, intent(out), optional :: rc
450 REAL(ESMF_KIND_R8) :: rsec
451 INTEGER(ESMF_KIND_I4) :: year, seconds, Sn, Sd
452 INTEGER(ESMF_KIND_I8), PARAMETER :: SECONDS_PER_DAY = 86400_ESMF_KIND_I8
454 CALL ESMF_TimeGet(time=time, yy=yy, yy_i8=yy_i8, &
459 ms=ms, us=us, ns=ns, &
460 d_r8=d_r8, h_r8=h_r8, m_r8=m_r8, s_r8=s_r8, &
461 ms_r8=ms_r8, us_r8=us_r8, ns_r8=ns_r8, &
463 ! 5.2.0r calendar=calendar, calendarType=calendarType, timeZone=timeZone, &
464 calendar=calendar, timeZone=timeZone, &
465 timeString=timeString, timeStringISOFrac=timeStringISOFrac, &
466 dayOfWeek=dayOfWeek, midMonth=midMonth, &
467 dayOfYear=dayOfYear, dayOfYear_R8=dayOfYear_r8, &
468 dayOfYear_intvl=dayOfYear_intvl, rc=rc)
469 IF ( rc == ESMF_SUCCESS ) THEN
470 IF ( PRESENT( dayOfYear_r8 ) ) THEN
471 ! get seconds since start of year and fractional seconds
472 CALL ESMF_TimeGet( time, yy=year, s=seconds, sN=Sn, sD=Sd, rc=rc )
473 IF ( rc == ESMF_SUCCESS ) THEN
474 ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold
475 ! number of seconds in a year...
476 rsec = REAL( seconds, ESMF_KIND_R8 )
477 IF ( PRESENT( Sd ) ) THEN
479 rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) )
482 dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 )
484 dayOfYear_r8 = dayOfYear_r8 + 1.0_ESMF_KIND_R8
489 end subroutine WRFU_TimeGet
491 !------------------------------------------------------------------------------
494 ! duplicated routines from esmf_time_f90
495 ! move these to a common shared location later...
497 ! Convert fraction to string with leading sign.
498 ! If fraction simplifies to a whole number or if
499 ! denominator is zero, return empty string.
500 ! INTEGER*8 interface.
501 SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str )
502 INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator
503 INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator
504 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
505 IF ( denominator > 0 ) THEN
506 IF ( mod( numerator, denominator ) /= 0 ) THEN
507 IF ( numerator > 0 ) THEN
508 WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator
510 WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator
512 ELSE ! includes numerator == 0 case
515 ELSE ! no-fraction case
518 END SUBROUTINE fraction_to_stringi8
521 ! Convert fraction to string with leading sign.
522 ! If fraction simplifies to a whole number or if
523 ! denominator is zero, return empty string.
525 SUBROUTINE fraction_to_string( numerator, denominator, frac_str )
526 INTEGER, INTENT(IN) :: numerator
527 INTEGER, INTENT(IN) :: denominator
528 CHARACTER (LEN=*), INTENT(OUT) :: frac_str
530 INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8
531 numerator_i8 = INT( numerator, ESMF_KIND_I8 )
532 denominator_i8 = INT( denominator, ESMF_KIND_I8 )
533 CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str )
534 END SUBROUTINE fraction_to_string
536 ! end of duplicated routines from esmf_time_f90
539 END MODULE module_esmf_extensions