! "module_esmf_extensions" is responsible for yet-to-be-implemented ESMF ! features used by the io_esmf package. Once ESMF development is complete, ! this module may be removed. ! NOTE for implementation of ESMF_*GetCurrent(): ! ! This implementation uses interfaces that pass Fortran POINTERs around ! to avoid forcing use of overloaded assignment operators for shallow ! copies. The goal of this approach is to be as insulated as possible ! from ESMF object implementations. This avoids having to explicitly ! copy-in *AND* copy-out through the standard component init(), run(), ! and final() interfaces just to attach references to ESMF objects to ! other objects. The explicit CICO *might* be required if we ! instead attached shallow copies of the objects to other objects! ! "Might" means it is not required now because ESMF objects are ! implemented as simple pointers. However, Nancy Collins says that ! the ESMF core team plans to add more state on the Fortran side of the ! ESMF objects, so copy-out will eventually be required. Thus we use ! POINTERs to attach references, as in other languages. Why ESMF ! component interfaces aren't passing POINTERs to Fortran objects is ! not clear (TBH)... ! MODULE module_esmf_extensions USE ESMF_Mod IMPLICIT NONE PRIVATE ! private data ! Data for ESMF_*GetCurrent() ! These flags are set to .TRUE. iff current objects are valid. LOGICAL, SAVE :: current_clock_valid = .FALSE. TYPE(ESMF_Clock), POINTER :: current_clock LOGICAL, SAVE :: current_importstate_valid = .FALSE. TYPE(ESMF_State), POINTER :: current_importstate LOGICAL, SAVE :: current_exportstate_valid = .FALSE. TYPE(ESMF_State), POINTER :: current_exportstate LOGICAL, SAVE :: current_gridcomp_valid = .FALSE. TYPE(ESMF_GridComp), POINTER :: current_gridcomp ! Flag for "is-initialized" inquiry ! NOTE: esmf_is_initialized is not reset to .FALSE. when ESMF_Finalize is called LOGICAL, SAVE :: esmf_is_initialized = .FALSE. ! public routines ! These convenience interfaces have been proposed to the ESMF core team. ! "get current" variants PUBLIC ESMF_ClockGetCurrent PUBLIC ESMF_ImportStateGetCurrent PUBLIC ESMF_ExportStateGetCurrent PUBLIC ESMF_GridCompGetCurrent ! "is-initialized" inquiry PUBLIC WRFU_IsInitialized ! extensions to standard ESMF interfaces ! these extensions conform to documented plans for ESMF extensions ! they should be removed as ESMF implementations are released PUBLIC WRFU_TimeGet ! public routines to be replaced by ESMF internal implementations ! These interfaces will not be public because ESMF will always be able ! to call them in the right places without user intervention. ! "get current" variants PUBLIC ESMF_ClockSetCurrent PUBLIC ESMF_ImportStateSetCurrent PUBLIC ESMF_ExportStateSetCurrent PUBLIC ESMF_GridCompSetCurrent PUBLIC ESMF_SetCurrent ! "is-initialized" inquiry PUBLIC ESMF_SetInitialized !!!!!!!!! added 20051012, JM ! Need to request that this interface be added... PUBLIC WRFU_TimeIntervalDIVQuot ! duplicated routines from esmf_time_f90 ! move these to a common shared location later... PUBLIC fraction_to_string ! hack for bug in PGI 5.1-x PUBLIC ESMF_TimeLE PUBLIC ESMF_TimeGE ! convenience function PUBLIC ESMF_TimeIntervalIsPositive CONTAINS ! Add "is initialized" behavior to ESMF interface FUNCTION WRFU_IsInitialized() LOGICAL WRFU_IsInitialized WRFU_IsInitialized = esmf_is_initialized END FUNCTION WRFU_IsInitialized ! Add "is initialized" behavior to ESMF interface ! This interface will go away as it will be done inside ESMF_Initialize(). SUBROUTINE ESMF_SetInitialized() esmf_is_initialized = .TRUE. END SUBROUTINE ESMF_SetInitialized ! -------------------------- ESMF-public method ------------------------------- !BOP ! !IROUTINE: ESMF_ClockGetCurrent - Get current ESMF_Clock ! !INTERFACE: SUBROUTINE ESMF_ClockGetCurrent(clock, rc) ! !ARGUMENTS: TYPE(ESMF_Clock), POINTER :: clock INTEGER, INTENT(OUT), OPTIONAL :: rc ! ! !DESCRIPTION: ! Get the {\tt ESMF\_Clock} object of the current execution context. ! ! The arguments are: ! \begin{description} ! \item[clock] ! Upon return this holds the {\tt ESMF\_Clock} object of the current context. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} ! !EOP ! !REQUIREMENTS: SSSn.n, GGGn.n !------------------------------------------------------------------------------ ! Assume failure until success IF ( PRESENT( rc ) ) rc = ESMF_FAILURE IF ( current_clock_valid ) THEN clock => current_clock IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS ENDIF END SUBROUTINE ESMF_ClockGetCurrent !------------------------------------------------------------------------------ ! -------------------------- ESMF-public method ------------------------------- !BOP ! !IROUTINE: ESMF_ImportStateGetCurrent - Get current import ESMF_State ! !INTERFACE: SUBROUTINE ESMF_ImportStateGetCurrent(importstate, rc) ! !ARGUMENTS: TYPE(ESMF_State), POINTER :: importstate INTEGER, INTENT(OUT), OPTIONAL :: rc ! ! !DESCRIPTION: ! Get the import {\tt ESMF\_State} object of the current execution context. ! ! The arguments are: ! \begin{description} ! \item[importstate] ! Upon return this holds the import {\tt ESMF\_State} object of the current context. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} ! !EOP ! !REQUIREMENTS: SSSn.n, GGGn.n !------------------------------------------------------------------------------ ! Assume failure until success IF ( PRESENT( rc ) ) rc = ESMF_FAILURE IF ( current_importstate_valid ) THEN importstate => current_importstate IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS ENDIF END SUBROUTINE ESMF_ImportStateGetCurrent !------------------------------------------------------------------------------ ! -------------------------- ESMF-public method ------------------------------- !BOP ! !IROUTINE: ESMF_ExportStateGetCurrent - Get current export ESMF_State ! !INTERFACE: SUBROUTINE ESMF_ExportStateGetCurrent(exportstate, rc) ! !ARGUMENTS: TYPE(ESMF_State), POINTER :: exportstate INTEGER, INTENT(OUT), OPTIONAL :: rc ! ! !DESCRIPTION: ! Get the export {\tt ESMF\_State} object of the current execution context. ! ! The arguments are: ! \begin{description} ! \item[exportstate] ! Upon return this holds the export {\tt ESMF\_State} object of the current context. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} ! !EOP ! !REQUIREMENTS: SSSn.n, GGGn.n !------------------------------------------------------------------------------ ! Assume failure until success IF ( PRESENT( rc ) ) rc = ESMF_FAILURE IF ( current_exportstate_valid ) THEN exportstate => current_exportstate IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS ENDIF END SUBROUTINE ESMF_ExportStateGetCurrent !------------------------------------------------------------------------------ ! -------------------------- ESMF-public method ------------------------------- !BOP ! !IROUTINE: ESMF_GridCompGetCurrent - Get current ESMF_GridComp ! !INTERFACE: SUBROUTINE ESMF_GridCompGetCurrent(gridcomp, rc) ! !ARGUMENTS: TYPE(ESMF_GridComp), POINTER :: gridcomp INTEGER, INTENT(OUT), OPTIONAL :: rc ! ! !DESCRIPTION: ! Get the {\tt ESMF\_GridComp} object of the current execution context. ! ! The arguments are: ! \begin{description} ! \item[gridcomp] ! Upon return this holds the {\tt ESMF\_GridComp} object of the current context. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} ! !EOP ! !REQUIREMENTS: SSSn.n, GGGn.n !------------------------------------------------------------------------------ ! Assume failure until success IF ( PRESENT( rc ) ) rc = ESMF_FAILURE IF ( current_gridcomp_valid ) THEN gridcomp => current_gridcomp IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS ENDIF END SUBROUTINE ESMF_GridCompGetCurrent !------------------------------------------------------------------------------ ! Temporary method, to be replaced by ESMF internal implementation ! Sets the current ESMF_Clock to clock. SUBROUTINE ESMF_ClockSetCurrent(clock) TYPE(ESMF_Clock), POINTER :: clock current_clock => clock current_clock_valid = .TRUE. END SUBROUTINE ESMF_ClockSetCurrent !------------------------------------------------------------------------------ ! Temporary method, to be replaced by ESMF internal implementation ! Sets the current import ESMF_State to importstate. SUBROUTINE ESMF_ImportStateSetCurrent(importstate) TYPE(ESMF_State), POINTER :: importstate current_importstate => importstate current_importstate_valid = .TRUE. END SUBROUTINE ESMF_ImportStateSetCurrent !------------------------------------------------------------------------------ ! Temporary method, to be replaced by ESMF internal implementation ! Sets the current export ESMF_State to exportstate. SUBROUTINE ESMF_ExportStateSetCurrent(exportstate) TYPE(ESMF_State), POINTER :: exportstate current_exportstate => exportstate current_exportstate_valid = .TRUE. END SUBROUTINE ESMF_ExportStateSetCurrent !------------------------------------------------------------------------------ ! Temporary method, to be replaced by ESMF internal implementation ! Sets the current ESMF_GridComp to gridcomp. SUBROUTINE ESMF_GridCompSetCurrent(gridcomp) TYPE(ESMF_GridComp), POINTER :: gridcomp current_gridcomp => gridcomp current_gridcomp_valid = .TRUE. END SUBROUTINE ESMF_GridCompSetCurrent !------------------------------------------------------------------------------ ! Temporary method, to be replaced by ESMF internal implementation ! Convenience interface to set everything at once... ! This routine sets the current ESMF_GridComp, import and export ! ESMF_States, and the current ESMF_Clock. ! NOTE: It will be possible to remove this routine once ESMF supports ! interfaces ESMF_ClockGetCurrent(), ESMF_ImportStateGetCurrent(), ! ESMF_ExportStateGetCurrent(), and ESMF_GridCompGetCurrent(). SUBROUTINE ESMF_SetCurrent( gcomp, importState, exportState, clock ) TYPE(ESMF_GridComp), OPTIONAL, POINTER :: gcomp TYPE(ESMF_State), OPTIONAL, POINTER :: importState TYPE(ESMF_State), OPTIONAL, POINTER :: exportState TYPE(ESMF_Clock), OPTIONAL, POINTER :: clock IF ( PRESENT( gcomp ) ) THEN CALL ESMF_GridCompSetCurrent( gcomp ) CALL ESMF_ImportStateSetCurrent( importState ) CALL ESMF_ExportStateSetCurrent( exportState ) CALL ESMF_ClockSetCurrent( clock ) ENDIF END SUBROUTINE ESMF_SetCurrent !------------------------------------------------------------------------------ ! begin hack for bug in PGI 5.1-x function ESMF_TimeLE(time1, time2) logical :: ESMF_TimeLE type(ESMF_Time), intent(in) :: time1 type(ESMF_Time), intent(in) :: time2 ESMF_TimeLE = (time1.LE.time2) end function ESMF_TimeLE function ESMF_TimeGE(time1, time2) logical :: ESMF_TimeGE type(ESMF_Time), intent(in) :: time1 type(ESMF_Time), intent(in) :: time2 ESMF_TimeGE = (time1.GE.time2) end function ESMF_TimeGE ! end hack for bug in PGI 5.1-x ! convenience function function ESMF_TimeIntervalIsPositive(timeinterval) logical :: ESMF_TimeIntervalIsPositive type(ESMF_TimeInterval), intent(in) :: timeinterval type(ESMF_TimeInterval) :: zerotimeint integer :: rcint CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint ) ESMF_TimeIntervalIsPositive = (timeinterval .GT. zerotimeint) end function ESMF_TimeIntervalIsPositive ! Note: this implementation is largely duplicated from external/esmf_time_f90 !!!!!!!!!!!!!!!!!! added jm 20051012 ! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder function WRFU_TimeIntervalDIVQuot(timeinterval1, timeinterval2) ! !RETURN VALUE: INTEGER :: WRFU_TimeIntervalDIVQuot ! !ARGUMENTS: type(ESMF_TimeInterval), intent(in) :: timeinterval1 type(ESMF_TimeInterval), intent(in) :: timeinterval2 ! !LOCAL INTEGER :: retval, isgn, rc type(ESMF_TimeInterval) :: zero, i1,i2 ! !DESCRIPTION: ! Returns timeinterval1 divided by timeinterval2 as a fraction quotient. ! ! The arguments are: ! \begin{description} ! \item[timeinterval1] ! The dividend ! \item[timeinterval2] ! The divisor ! \end{description} ! ! !REQUIREMENTS: ! TMG1.5.5 !EOP call ESMF_TimeIntervalSet( zero, rc=rc ) i1 = timeinterval1 i2 = timeinterval2 isgn = 1 if ( i1 .LT. zero ) then i1 = i1 * (-1) isgn = -isgn endif if ( i2 .LT. zero ) then i2 = i2 * (-1) isgn = -isgn endif ! repeated subtraction retval = 0 DO WHILE ( i1 .GE. i2 ) i1 = i1 - i2 retval = retval + 1 ENDDO retval = retval * isgn WRFU_TimeIntervalDIVQuot = retval end function WRFU_TimeIntervalDIVQuot !!!!!!!!!!!!!!!!!! ! implementations of extensions to standard ESMF interfaces ! these extensions conform to documented plans for ESMF extensions ! they should be removed as ESMF implementations are released ! extend ESMF_TimeGet() to make dayOfYear_r8 work... subroutine WRFU_TimeGet(time, yy, yy_i8, & mm, dd, & d, d_i8, & h, m, & s, s_i8, & ms, us, ns, & d_r8, h_r8, m_r8, s_r8, & ms_r8, us_r8, ns_r8, & sN, sD, & calendar, calendarType, timeZone, & timeString, timeStringISOFrac, & dayOfWeek, midMonth, & dayOfYear, dayOfYear_r8, & dayOfYear_intvl, rc) type(ESMF_Time), intent(in) :: time integer(ESMF_KIND_I4), intent(out), optional :: yy integer(ESMF_KIND_I8), intent(out), optional :: yy_i8 integer, intent(out), optional :: mm integer, intent(out), optional :: dd integer(ESMF_KIND_I4), intent(out), optional :: d integer(ESMF_KIND_I8), intent(out), optional :: d_i8 integer(ESMF_KIND_I4), intent(out), optional :: h integer(ESMF_KIND_I4), intent(out), optional :: m integer(ESMF_KIND_I4), intent(out), optional :: s integer(ESMF_KIND_I8), intent(out), optional :: s_i8 integer(ESMF_KIND_I4), intent(out), optional :: ms integer(ESMF_KIND_I4), intent(out), optional :: us integer(ESMF_KIND_I4), intent(out), optional :: ns real(ESMF_KIND_R8), intent(out), optional :: d_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: h_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: m_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: s_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: ms_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: us_r8 ! not implemented real(ESMF_KIND_R8), intent(out), optional :: ns_r8 ! not implemented integer(ESMF_KIND_I4), intent(out), optional :: sN integer(ESMF_KIND_I4), intent(out), optional :: sD type(ESMF_Calendar), intent(out), optional :: calendar type(ESMF_CalendarType), intent(out), optional :: calendarType integer, intent(out), optional :: timeZone character (len=*), intent(out), optional :: timeString character (len=*), intent(out), optional :: timeStringISOFrac integer, intent(out), optional :: dayOfWeek type(ESMF_Time), intent(out), optional :: midMonth integer(ESMF_KIND_I4), intent(out), optional :: dayOfYear real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8 ! NOW implemented type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl integer, intent(out), optional :: rc REAL(ESMF_KIND_R8) :: rsec INTEGER(ESMF_KIND_I4) :: year, seconds, Sn, Sd INTEGER(ESMF_KIND_I8), PARAMETER :: SECONDS_PER_DAY = 86400_ESMF_KIND_I8 call ESMF_TimeGet(time, yy, yy_i8, & mm, dd, & d, d_i8, & h, m, & s, s_i8, & ms, us, ns, & d_r8, h_r8, m_r8, s_r8, & ms_r8, us_r8, ns_r8, & sN, sD, & calendar, calendarType, timeZone, & timeString, timeStringISOFrac, & dayOfWeek, midMonth, & dayOfYear, dayOfYear_r8, & dayOfYear_intvl, rc) IF ( rc == ESMF_SUCCESS ) THEN IF ( PRESENT( dayOfYear_r8 ) ) THEN ! get seconds since start of year and fractional seconds CALL ESMF_TimeGet( time, yy=year, s=seconds, sN=Sn, sD=Sd, rc=rc ) IF ( rc == ESMF_SUCCESS ) THEN ! 64-bit IEEE 754 has 52-bit mantisssa -- only need 25 bits to hold ! number of seconds in a year... rsec = REAL( seconds, ESMF_KIND_R8 ) IF ( Sd /= 0 ) THEN rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) ) ENDIF dayOfYear_r8 = rsec / REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) ! start at 1 dayOfYear_r8 = dayOfYear_r8 + 1.0_ESMF_KIND_R8 ENDIF ENDIF ENDIF end subroutine WRFU_TimeGet !------------------------------------------------------------------------------ ! duplicated routines from esmf_time_f90 ! move these to a common shared location later... ! Convert fraction to string with leading sign. ! If fraction simplifies to a whole number or if ! denominator is zero, return empty string. ! INTEGER*8 interface. SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str ) INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator CHARACTER (LEN=*), INTENT(OUT) :: frac_str IF ( denominator > 0 ) THEN IF ( mod( numerator, denominator ) /= 0 ) THEN IF ( numerator > 0 ) THEN WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator ELSE ! numerator < 0 WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator ENDIF ELSE ! includes numerator == 0 case frac_str = '' ENDIF ELSE ! no-fraction case frac_str = '' ENDIF END SUBROUTINE fraction_to_stringi8 ! Convert fraction to string with leading sign. ! If fraction simplifies to a whole number or if ! denominator is zero, return empty string. ! INTEGER interface. SUBROUTINE fraction_to_string( numerator, denominator, frac_str ) INTEGER, INTENT(IN) :: numerator INTEGER, INTENT(IN) :: denominator CHARACTER (LEN=*), INTENT(OUT) :: frac_str ! locals INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8 numerator_i8 = INT( numerator, ESMF_KIND_I8 ) denominator_i8 = INT( denominator, ESMF_KIND_I8 ) CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str ) END SUBROUTINE fraction_to_string ! end of duplicated routines from esmf_time_f90 END MODULE module_esmf_extensions