diff --git a/CMakeLists.txt b/CMakeLists.txt index 34a9c4d35e30..241ab190c49d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -229,6 +229,7 @@ add_subdirectory (base) add_subdirectory (MAPL) add_subdirectory (gridcomps) add_subdirectory (griddedio) +add_subdirectory (udunits2f) if (BUILD_WITH_FARGPARSE) add_subdirectory (docs) add_subdirectory (benchmarks) diff --git a/cmake/Findudunits.cmake b/cmake/Findudunits.cmake new file mode 100644 index 000000000000..4978694b91ac --- /dev/null +++ b/cmake/Findudunits.cmake @@ -0,0 +1,68 @@ +# (C) Copyright 2022- UCAR. +# +# Try to find the udunits headers and library +# +# This module defines: +# +# - udunits::udunits - The udunits shared library and include directory, all in a single target. +# - udunits_FOUND - True if udunits was found +# - udunits_INCLUDE_DIR - The include directory +# - udunits_LIBRARY - The library +# - udunits_LIBRARY_SHARED - Whether the library is shared or not +# - udunits_XML_PATH - path to udunits2.xml +# +# The following paths will be searched in order if set in CMake (first priority) or environment (second priority): +# +# - UDUNITS2_INCLUDE_DIRS & UDUNITS2_LIBRARIES - folders containing udunits2.h and libudunits2, respectively. +# - UDUNITS2_ROOT - root of udunits installation +# - UDUNITS2_PATH - root of udunits installation +# +# Notes: +# - The hint variables are capitalized because this is how they are exposed in the jedi stack. +# See https://github.com/JCSDA-internal/jedi-stack/blob/develop/modulefiles/compiler/compilerName/compilerVersion/udunits/udunits.lua for details. + +find_path ( + udunits_INCLUDE_DIR + udunits2.h + HINTS ${UDUNITS2_INCLUDE_DIRS} $ENV{UDUNITS2_INCLUDE_DIRS} + ${UDUNITS2_ROOT} $ENV{UDUNITS2_ROOT} + ${UDUNITS2_PATH} $ENV{UDUNITS2_PATH} + PATH_SUFFIXES include include/udunits2 + DOC "Path to udunits2.h" ) + +find_file ( + udunits_XML_PATH + udunits2.xml + HINTS ${UDUNITS2_XML_PATH} $ENV{UDUNITS2_XML_PATH} + ${UDUNITS2_ROOT} $ENV{UDUNITS2_ROOT} + ${UDUNITS2_PATH} $ENV{UDUNITS2_PATH} + PATH_SUFFIXES share share/udunits + DOC "Path to udunits2.xml" ) + +find_library(udunits_LIBRARY + NAMES udunits2 udunits + HINTS ${UDUNITS2_LIBRARIES} $ENV{UDUNITS2_LIBRARIES} + ${UDUNITS2_ROOT} $ENV{UDUNITS2_ROOT} + ${UDUNITS2_PATH} $ENV{UDUNITS2_PATH} + PATH_SUFFIXES lib64 lib + DOC "Path to libudunits library" ) + +# We need to support both static and shared libraries +if (udunits_LIBRARY MATCHES ".*\\.a$") + set(udunits_LIBRARY_SHARED FALSE) +else() + set(udunits_LIBRARY_SHARED TRUE) +endif() + +include (FindPackageHandleStandardArgs) +find_package_handle_standard_args (udunits DEFAULT_MSG udunits_LIBRARY udunits_INCLUDE_DIR udunits_XML_PATH) + +mark_as_advanced (udunits_LIBRARY udunits_INCLUDE_DIR udunits_XML_PATH) + +if(udunits_FOUND AND NOT TARGET udunits::udunits) + add_library(udunits::udunits INTERFACE IMPORTED) + set_target_properties(udunits::udunits PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${udunits_INCLUDE_DIR}) + set_target_properties(udunits::udunits PROPERTIES INTERFACE_LINK_LIBRARIES ${udunits_LIBRARY}) + set_property(TARGET udunits::udunits APPEND PROPERTY INTERFACE_LINK_LIBRARIES ${CMAKE_DL_LIBS}) +endif() + diff --git a/udunits2f/CMakeLists.txt b/udunits2f/CMakeLists.txt new file mode 100644 index 000000000000..9ddd633fc535 --- /dev/null +++ b/udunits2f/CMakeLists.txt @@ -0,0 +1,28 @@ +esma_set_this (OVERRIDE udunits2f) + +set(srcs + CptrWrapper.F90 + UDSystem.F90 + udunits2f.F90 + encoding.F90 + interfaces.F90 + status_codes.F90 + ut_set_ignore_error_message_handler.c + ) +list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}") + +esma_add_library(${this} + SRCS ${srcs} + TYPE SHARED +) + +find_package(udunits REQUIRED) +find_package(EXPAT REQUIRED) + +target_link_libraries(${this} PUBLIC udunits::udunits) +target_link_libraries(${this} PUBLIC EXPAT::EXPAT) + +if (PFUNIT_FOUND) + # Turning off until test with GNU can be fixed + add_subdirectory(tests EXCLUDE_FROM_ALL) +endif () diff --git a/udunits2f/CptrWrapper.F90 b/udunits2f/CptrWrapper.F90 new file mode 100644 index 000000000000..8b0143c6b70b --- /dev/null +++ b/udunits2f/CptrWrapper.F90 @@ -0,0 +1,64 @@ +module ud2f_CptrWrapper + use, intrinsic :: iso_c_binding, only: c_ptr, C_NULL_PTR, c_associated + implicit none + private + + public :: CptrWrapper + +!================================ CPTRWRAPPER ================================== +! Base class to wrap type(c_ptr) instances used for udunits2 objects that cannot +! interface directly to fortran. Each extended class must provide a subroutine +! to free the memory associated with cptr_ + type, abstract :: CptrWrapper + private + type(c_ptr) :: cptr_ = C_NULL_PTR + contains + procedure :: get_cptr + procedure :: set_cptr + procedure :: is_free + procedure :: free + procedure(I_free_memory), deferred :: free_memory + end type CptrWrapper + + abstract interface + + subroutine I_free_memory(this) + import :: CptrWrapper + class(CptrWrapper), intent(in) :: this + end subroutine I_Free_Memory + + end interface + +contains + + type(c_ptr) function get_cptr(this) + class(CptrWrapper), intent(in) :: this + + get_cptr = this%cptr_ + + end function get_cptr + + subroutine set_cptr(this, cptr) + class(CptrWrapper), intent(inout) :: this + type(c_ptr), intent(in) :: cptr + this%cptr_ = cptr + end subroutine set_cptr + + logical function is_free(this) + class(CptrWrapper), intent(in) :: this + + is_free = .not. c_associated(this%cptr_) + + end function is_free + + ! Free up memory pointed to by cptr_ and set cptr_ to c_null_ptr + subroutine free(this) + class(CptrWrapper), intent(inout) :: this + + if(this%is_free()) return + call this%free_memory() + this%cptr_ = c_null_ptr + + end subroutine free + +end module ud2f_CptrWrapper diff --git a/udunits2f/UDSystem.F90 b/udunits2f/UDSystem.F90 new file mode 100644 index 000000000000..0fe1386978ed --- /dev/null +++ b/udunits2f/UDSystem.F90 @@ -0,0 +1,444 @@ +#include "error_handling.h" + +module ud2f_UDSystem + use ud2f_CptrWrapper + use ud2f_interfaces + use ud2f_encoding + use ud2f_status_codes + use iso_c_binding, only: c_ptr, c_associated, c_null_ptr, c_null_char + use iso_c_binding, only: c_char, c_int, c_float, c_double, c_loc + implicit none + private + + public :: Converter + public :: get_converter + public :: initialize + public :: finalize + + public :: UDUnit + public :: are_convertible + public :: UDSystem + public :: cstring + public :: read_xml + public :: ut_free_system + +!================================= CONVERTER =================================== +! Converter object to hold convert functions for an (order) pair of units + type, extends(CptrWrapper) :: Converter + private + contains + procedure :: free_memory => free_cv_converter + procedure, private :: convert_float_0d + procedure, private :: convert_float_1d + procedure, private :: convert_float_2d + procedure, private :: convert_float_3d + procedure, private :: convert_float_4d + procedure, private :: convert_float_5d + procedure, private :: convert_double_0d + procedure, private :: convert_double_1d + procedure, private :: convert_double_2d + procedure, private :: convert_double_3d + procedure, private :: convert_double_4d + procedure, private :: convert_double_5d + + generic :: convert => convert_float_0d + generic :: convert => convert_float_1d + generic :: convert => convert_float_2d + generic :: convert => convert_float_3d + generic :: convert => convert_float_4d + generic :: convert => convert_float_5d + generic :: convert => convert_double_0d + generic :: convert => convert_double_1d + generic :: convert => convert_double_2d + generic :: convert => convert_double_3d + generic :: convert => convert_double_4d + generic :: convert => convert_double_5d + end type Converter + + interface Converter + module procedure :: construct_converter + end interface Converter + +!=============================== UDSYSTEM ================================= +! udunits2 unit system: encoding is the encoding for unit names and symbols. + type, extends(CptrWrapper) :: UDSystem + private + integer(ut_encoding) :: encoding = UT_ASCII + contains + procedure, public, pass(this) :: free_memory => free_ut_system + end type UDSystem + + interface UDSystem + module procedure :: construct_system + end interface UDSystem + +!=================================== UDUNIT ==================================== +! measurement unit in udunits2 system + type, extends(CptrWrapper) :: UDUnit + contains + procedure, public, pass(this) :: free_memory => free_ut_unit + end type UDUnit + + interface UDUnit + module procedure :: construct_unit + end interface UDUnit + + interface are_convertible + procedure :: are_convertible_udunit + procedure :: are_convertible_str + end interface are_convertible + +!============================= INSTANCE VARIABLES ============================== +! Single instance of units system. There is one system in use, only. + type(UDSystem), private :: SYSTEM_INSTANCE + +contains + + ! Check the status for the last udunits2 call + logical function success(utstatus) + integer(ut_status) :: utstatus + + success = (utstatus == UT_SUCCESS) + + end function success + + function construct_system(path, encoding) result(instance) + type(UDsystem) :: instance + character(len=*), optional, intent(in) :: path + integer(ut_encoding), optional, intent(in) :: encoding + type(c_ptr) :: utsystem + integer(ut_status) :: status + + ! Read in unit system from path + call read_xml(path, utsystem, status) + + if(success(status)) then + call instance%set_cptr(utsystem) + if(present(encoding)) instance%encoding = encoding + return + end if + + ! Free memory in the case of failure + if(c_associated(utsystem)) call ut_free_system(utsystem) + + end function construct_system + + function construct_unit(identifier) result(instance) + type(UDUnit) :: instance + character(len=*), intent(in) :: identifier + character(kind=c_char, len=:), allocatable :: cchar_identifier + type(c_ptr) :: utunit1 + + ! Unit system must be initialized (instantiated). + if(instance_is_uninitialized()) return + + cchar_identifier = cstring(identifier) + utunit1 = ut_parse(SYSTEM_INSTANCE%get_cptr(), cchar_identifier, SYSTEM_INSTANCE%encoding) + + if(success(ut_get_status())) then + call instance%set_cptr(utunit1) + else + ! Free memory in the case of failure + if(c_associated(utunit1)) call ut_free(utunit1) + end if + + end function construct_unit + + function construct_converter(from_unit, to_unit) result(conv) + type(Converter) :: conv + type(UDUnit), intent(in) :: from_unit + type(UDUnit), intent(in) :: to_unit + type(c_ptr) :: cvconverter1 + logical :: convertible + + ! Must supply units that are initialized and convertible + if(from_unit%is_free() .or. to_unit%is_free()) return + if(.not. are_convertible(from_unit, to_unit)) return + + cvconverter1 = ut_get_converter(from_unit%get_cptr(), to_unit%get_cptr()) + + if(success(ut_get_status())) then + call conv%set_cptr(cvconverter1) + else + ! Free memory in the case of failure + if(c_associated(cvconverter1)) call cv_free(cvconverter1) + end if + + end function construct_converter + + ! Get Converter object based on unit names or symbols + subroutine get_converter(conv, from, to, rc) + type(Converter),intent(inout) :: conv + character(len=*), intent(in) :: from, to + integer(ut_status), optional, intent(out) :: rc + integer(ut_status) :: status + + conv = get_converter_function(from, to) + _ASSERT(.not. conv%is_free(), UTF_CONVERTER_NOT_INITIALIZED) + + _RETURN(UT_SUCCESS) + end subroutine get_converter + + ! Get converter object + function get_converter_function(from, to) result(conv) + type(Converter) :: conv + character(len=*), intent(in) :: from, to + type(UDUnit) :: from_unit + type(UDUnit) :: to_unit + + ! Unit system must be initialized (instantiated). + if(instance_is_uninitialized()) return + + ! Get units based on strings. Free memory on fail. + from_unit = UDUnit(from) + if(from_unit%is_free()) return + to_unit = UDUnit(to) + if(to_unit%is_free()) then + call from_unit%free() + return + end if + + conv = Converter(from_unit, to_unit) + + ! Units are no longer needed + call from_unit%free() + call to_unit%free() + + end function get_converter_function + + function convert_float_0d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from + real(c_float) :: to + to = cv_convert_float(this%get_cptr(), from) + end function convert_float_0d + + function convert_float_1d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from(:) + real(c_float) :: to(size(from)) + call cv_convert_floats(this%get_cptr(), from, size(from), to) + end function convert_float_1d + + function convert_float_2d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from(:,:) + real(c_float) :: to(size(from,1), size(from,2)) + call cv_convert_floats(this%get_cptr(), from, size(from), to) + end function convert_float_2d + + function convert_float_3d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from(:,:,:) + real(c_float) :: to(size(from,1), size(from,2), size(from,3)) + call cv_convert_floats(this%get_cptr(), from, size(from), to) + end function convert_float_3d + + function convert_float_4d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from(:,:,:,:) + real(c_float) :: to(size(from,1), size(from,2), size(from,3), size(from,4)) + call cv_convert_floats(this%get_cptr(), from, size(from), to) + end function convert_float_4d + + function convert_float_5d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_float), intent(in) :: from(:,:,:,:,:) + real(c_float) :: to(size(from,1), size(from,2), size(from,3), size(from,4), size(from,5)) + call cv_convert_floats(this%get_cptr(), from, size(from), to) + end function convert_float_5d + + function convert_double_0d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from + real(c_double) :: to + to = cv_convert_double(this%get_cptr(), from) + end function convert_double_0d + + function convert_double_1d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from(:) + real(c_double) :: to(size(from)) + call cv_convert_doubles(this%get_cptr(), from, size(from), to) + end function convert_double_1d + + function convert_double_2d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from(:,:) + real(c_double) :: to(size(from,1), size(from,2)) + call cv_convert_doubles(this%get_cptr(), from, size(from), to) + end function convert_double_2d + + function convert_double_3d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from(:,:,:) + real(c_double) :: to(size(from,1), size(from,2), size(from,3)) + call cv_convert_doubles(this%get_cptr(), from, size(from), to) + end function convert_double_3d + + function convert_double_4d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from(:,:,:,:) + real(c_double) :: to(size(from,1), size(from,2), size(from,3), size(from,4)) + call cv_convert_doubles(this%get_cptr(), from, size(from), to) + end function convert_double_4d + + function convert_double_5d(this, from) result(to) + class(Converter), intent(in) :: this + real(c_double), intent(in) :: from(:,:,:,:,:) + real(c_double) :: to(size(from,1), size(from,2), size(from,3), size(from,4), size(from,5)) + call cv_convert_doubles(this%get_cptr(), from, size(from), to) + end function convert_double_5d + + ! Read unit database from XML + subroutine read_xml(path, utsystem, status) + character(len=*), optional, intent(in) :: path + type(c_ptr), intent(out) :: utsystem + integer(ut_status), intent(out) :: status + + character(kind=c_char, len=:), target, allocatable :: cchar_path + + if(present(path)) then + cchar_path = cstring(path) + utsystem = ut_read_xml_cptr(c_loc(cchar_path)) + else + utsystem = ut_read_xml_cptr(c_null_ptr) + end if + status = ut_get_status() + + end subroutine read_xml + + ! Initialize unit system instance + subroutine initialize(path, encoding, rc) + character(len=*), optional, intent(in) :: path + integer(ut_encoding), optional, intent(in) :: encoding + integer, optional, intent(out) :: rc + integer :: status + + _RETURN_UNLESS(instance_is_uninitialized()) + ! System must be once and only once. + _ASSERT(instance_is_uninitialized(), UTF_DUPLICATE_INITIALIZATION) + + ! Disable error messages from udunits2 + call disable_ut_error_message_handler() + + call initialize_system(SYSTEM_INSTANCE, path, encoding, rc=status) + if(status /= UT_SUCCESS) then + ! On failure, free memory + call finalize() + _RETURN(UTF_INITIALIZATION_FAILURE) + end if + _ASSERT(.not. SYSTEM_INSTANCE%is_free(), UTF_NOT_INITIALIZED) + _RETURN(UT_SUCCESS) + + end subroutine initialize + + subroutine initialize_system(system, path, encoding, rc) + type(UDSystem), intent(inout) :: system + character(len=*), optional, intent(in) :: path + integer(ut_encoding), optional, intent(in) :: encoding + integer, optional, intent(out) :: rc + integer :: status + type(c_ptr) :: utsystem + + ! A system can be initialized only once. + _ASSERT(system%is_free(), UTF_DUPLICATE_INITIALIZATION) + + system = UDSystem(path, encoding) + _RETURN(UT_SUCCESS) + end subroutine initialize_system + + ! Is the instance of the unit system initialized? + logical function instance_is_uninitialized() + + instance_is_uninitialized = SYSTEM_INSTANCE%is_free() + + end function instance_is_uninitialized + + ! Free memory for unit system + subroutine free_ut_system(this) + class(UDSystem), intent(in) :: this + + if(this%is_free()) return + call ut_free_system(this%get_cptr()) + + end subroutine free_ut_system + + ! Free memory for unit + subroutine free_ut_unit(this) + class(UDUnit), intent(in) :: this + + if(this%is_free()) return + call ut_free(this%get_cptr()) + + end subroutine free_ut_unit + + ! Free memory for converter + subroutine free_cv_converter(this) + class(Converter), intent(in) :: this + type(c_ptr) :: cvconverter1 + + if(this%is_free()) return + call cv_free(this%get_cptr()) + + end subroutine free_cv_converter + + ! Free memory for unit system instance + subroutine finalize() + + if(SYSTEM_INSTANCE%is_free()) return + call SYSTEM_INSTANCE%free() + + end subroutine finalize + + ! Check if units are convertible + function are_convertible_udunit(unit1, unit2, rc) result(convertible) + logical :: convertible + type(UDUnit), intent(in) :: unit1, unit2 + integer, optional, intent(out) :: rc + integer :: status + integer(c_int), parameter :: ZERO = 0_c_int + + convertible = (ut_are_convertible(unit1%get_cptr(), unit2%get_cptr()) /= ZERO) + status = ut_get_status() + _ASSERT(success(status), status) + + _RETURN(UT_SUCCESS) + end function are_convertible_udunit + + ! Check if units are convertible + function are_convertible_str(from, to, rc) result(convertible) + logical :: convertible + character(*), intent(in) :: from, to + integer, optional, intent(out) :: rc + + integer :: status + type(UDUnit) :: unit1, unit2 + + unit1 = UDUnit(from) + unit2 = UDUnit(to) + convertible = are_convertible_udunit(unit1, unit2, _RC) + + _RETURN(UT_SUCCESS) + end function are_convertible_str + + ! Create C string from Fortran string + function cstring(s) result(cs) + character(len=*), intent(in) :: s + character(kind=c_char, len=:), allocatable :: cs + + cs = adjustl(trim(s)) // c_null_char + + end function cstring + + ! Set udunits2 error handler to ut_ignore which does nothing + subroutine disable_ut_error_message_handler(is_set) + logical, optional, intent(out) :: is_set + logical, save :: handler_set = .FALSE. + + if(.not. handler_set) call ut_set_ignore_error_message_handler() + handler_set = .TRUE. + if(present(is_set)) is_set = handler_set + end subroutine disable_ut_error_message_handler + +end module ud2f_UDSystem diff --git a/udunits2f/encoding.F90 b/udunits2f/encoding.F90 new file mode 100644 index 000000000000..0daa08205deb --- /dev/null +++ b/udunits2f/encoding.F90 @@ -0,0 +1,17 @@ +! Flags for encodings for unit names and symbols +! The values are the same as the udunits2 utEncoding C enum +module ud2f_encoding + implicit none + public + + enum, bind(c) + enumerator :: UT_ASCII = 0 + enumerator :: UT_ISO_8859_1 = 1 + enumerator :: UT_LATIN1 = UT_ISO_8859_1 + enumerator :: UT_UTF8 = 2 + enumerator :: UT_ENCODING_DEFAULT = UT_ASCII + end enum + integer, parameter :: ut_encoding = kind(UT_ENCODING_DEFAULT) + +end module ud2f_encoding + diff --git a/udunits2f/error_handling.h b/udunits2f/error_handling.h new file mode 100644 index 000000000000..78892070d455 --- /dev/null +++ b/udunits2f/error_handling.h @@ -0,0 +1,6 @@ +#define _RETURN(status) if(present(rc)) then; rc=status; return; endif +#define _RETURN_UNLESS(cond) if (.not. cond) then; _RETURN(UT_SUCCESS); endif +#define _ASSERT(cond, msg) if (.not. (cond)) then; _RETURN(msg); endif +#define _RC rc=status); _ASSERT(rc==UT_SUCCESS, status + +!rc=status); if (.not. (rc==UT_SUCCESS)) then; if(present(rc)) then; rc=status; return; endif; endif diff --git a/udunits2f/interfaces.F90 b/udunits2f/interfaces.F90 new file mode 100644 index 000000000000..34d47e205f50 --- /dev/null +++ b/udunits2f/interfaces.F90 @@ -0,0 +1,138 @@ +module ud2f_interfaces + use ud2f_encoding, only: ut_encoding + use ud2f_status_codes, only: ut_status + use, intrinsic :: iso_c_binding, only: c_ptr, c_char, c_int, c_float, c_double + implicit none + private + + public :: ut_get_status, ut_parse + public :: ut_read_xml_cptr + public :: ut_get_converter, ut_are_convertible + public :: cv_convert_double, cv_convert_float + public :: cv_convert_doubles, cv_convert_floats + public :: ut_free, ut_free_system, cv_free + public :: ut_set_ignore_error_message_handler + interface + + ! Procedures that return type(c_ptr) return a C null pointer on failure. + ! However, checking for the C null pointer IS NOT a good check for status. + ! ut_get_status is a better check, where UT_SUCCESS indicates success. + + ! Return type(c_ptr) to ut_system units database specified by path + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + type(c_ptr) function ut_read_xml_cptr(path) bind(c, name='ut_read_xml') + import :: c_ptr + type(c_ptr), value :: path + end function ut_read_xml_cptr + + ! Get status code + integer(ut_status) function ut_get_status() bind(c, name='ut_get_status') + import :: ut_status + end function ut_get_status + + ! Return non-zero value if unit1 can be converted to unit2, otherwise 0 + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + integer(c_int) function ut_are_convertible(unit1, unit2) & + bind(c, name='ut_are_convertible') + import :: c_int, c_ptr + type(c_ptr), value, intent(in) :: unit1, unit2 + end function ut_are_convertible + + ! Return type(c_ptr) to cv_converter + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + type(c_ptr) function ut_get_converter(from, to) & + bind(c, name='ut_get_converter') + import :: c_ptr + type(c_ptr), value, intent(in) :: from, to + end function ut_get_converter + + ! Use converter to convert value_ + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + real(c_float) function cv_convert_float(converter, value_) bind(c) + import :: c_ptr, c_float + type(c_ptr), value, intent(in) :: converter + real(c_float), value, intent(in) :: value_ + end function cv_convert_float + + ! Use converter to convert value_ + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + real(c_double) function cv_convert_double(converter, value_) bind(c) + import :: c_ptr, c_double + type(c_ptr), value, intent(in) :: converter + real(c_double), value, intent(in) :: value_ + end function cv_convert_double + + ! Use converter to convert in_ and put it in out_. + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + subroutine cv_convert_doubles(converter, in_, count_, out_) & + bind(c, name='cv_convert_doubles') + import :: c_double, c_int, c_ptr + type(c_ptr), value, intent(in) :: converter + real(c_double), intent(in) :: in_(*) + integer(c_int), value, intent(in) :: count_ + real(c_double), intent(out) :: out_(count_) + end subroutine cv_convert_doubles + + ! Use converter to convert in_ and put it in out_. + ! Use ut_get_status to check error condition. + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + subroutine cv_convert_floats(converter, in_, count_, out_) & + bind(c, name='cv_convert_floats') + import :: c_ptr, c_float, c_int + type(c_ptr), value, intent(in) :: converter + real(c_float), intent(in) :: in_(*) + integer(c_int), value, intent(in) :: count_ + real(c_float), intent(out) :: out_(count_) + end subroutine cv_convert_floats + + ! Return type(c_ptr) to ut_unit + ! UT_SUCCESS indicates that the function ran successfully. + ! Other ut_status codes indicate cause of failure. + ! Use ut_get_status to check error condition. + type(c_ptr) function ut_parse(system, string, encoding) & + bind(c, name='ut_parse') + import :: c_ptr, c_char, ut_encoding + type(c_ptr), value, intent(in) :: system + character(c_char), intent(in) :: string(*) + integer(ut_encoding), value, intent(in) :: encoding + end function ut_parse + + ! Free memory for ut_system + subroutine ut_free_system(system) bind(c, name='ut_free_system') + import :: c_ptr + type(c_ptr), value :: system + end subroutine ut_free_system + + ! Free memory for ut_unit + subroutine ut_free(unit) bind(c, name='ut_free') + import :: c_ptr + type(c_ptr), value :: unit + end subroutine ut_free + + ! Free memory for cv_converter + subroutine cv_free(conv) bind(c, name='cv_free') + import :: c_ptr + type(c_ptr), value :: conv + end subroutine cv_free + + ! Set udunits error handler to ut_ignore (do nothing) + subroutine ut_set_ignore_error_message_handler() & + bind(c, name='ut_set_ignore_error_message_handler') + end subroutine ut_set_ignore_error_message_handler + + end interface + +end module ud2f_interfaces diff --git a/udunits2f/status_codes.F90 b/udunits2f/status_codes.F90 new file mode 100644 index 000000000000..d57338aeb5c8 --- /dev/null +++ b/udunits2f/status_codes.F90 @@ -0,0 +1,37 @@ +! Status values for udunits2 procedures +! The values are the same as the udunits2 utStatus C enum +module ud2f_status_codes + + implicit none + + enum, bind(c) + enumerator :: & + UT_SUCCESS = 0, & ! Success + UT_BAD_ARG, & ! An argument violates the function's contract + UT_EXISTS, & ! Unit, prefix, or identifier already exists + UT_NO_UNIT, & ! No such unit exists + UT_OS, & ! Operating-system error. See "errno". + UT_NOT_SAME_SYSTEM, & ! The units belong to different unit-systems + UT_MEANINGLESS, & ! The operation on the unit(s) is meaningless + UT_NO_SECOND, & ! The unit-system doesn't have a unit named "second" + UT_VISIT_ERROR, & ! An error occurred while visiting a unit + UT_CANT_FORMAT, & ! A unit can't be formatted in the desired manner + UT_SYNTAX, & ! string unit representation contains syntax error + UT_UNKNOWN, & ! string unit representation contains unknown word + UT_OPEN_ARG, & ! Can't open argument-specified unit database + UT_OPEN_ENV, & ! Can't open environment-specified unit database + UT_OPEN_DEFAULT, & ! Can't open installed, default, unit database + UT_PARSE_ERROR ! Error parsing unit specification + end enum + integer, parameter :: ut_status = kind(UT_SUCCESS) + + enum, bind(c) + enumerator :: & + UTF_DUPLICATE_INITIALIZATION = 100, & + UTF_CONVERTER_NOT_INITIALIZED, & + UTF_NOT_INITIALIZED, & + UTF_INITIALIZATION_FAILURE + + end enum + +end module ud2f_status_codes diff --git a/udunits2f/tests/CMakeLists.txt b/udunits2f/tests/CMakeLists.txt new file mode 100644 index 000000000000..7b5be2e4b42a --- /dev/null +++ b/udunits2f/tests/CMakeLists.txt @@ -0,0 +1,26 @@ +set(MODULE_DIRECTORY "${esma_include}/udunits2f.tests") + +set (test_srcs + Test_UDSystem.pf + Test_udunits2f.pf + ) + +add_pfunit_ctest(udunits2f.tests + TEST_SOURCES ${test_srcs} + LINK_LIBRARIES udunits2f + ) +set_target_properties(udunits2f.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(udunits2f.tests PROPERTIES LABELS "ESSENTIAL") + +# With this test, it was shown that if you are building with the GNU Fortran +# compiler and *not* on APPLE, then you need to link with the dl library. +if (CMAKE_Fortran_COMPILER_ID STREQUAL "GNU" AND NOT APPLE) + target_link_libraries(udunits2f.tests ${CMAKE_DL_LIBS}) +endif () + +# This test requires UDUNITS2_XML_PATH to be set to the location of the udunits2.xml file +# This is found by Findudunits.cmake and stored in the variable udunits_XML_PATH +set_tests_properties(udunits2f.tests PROPERTIES ENVIRONMENT "UDUNITS2_XML_PATH=${udunits_XML_PATH}") + +add_dependencies(build-tests udunits2f.tests) + diff --git a/udunits2f/tests/Test_UDSystem.pf b/udunits2f/tests/Test_UDSystem.pf new file mode 100644 index 000000000000..14f8979a656d --- /dev/null +++ b/udunits2f/tests/Test_UDSystem.pf @@ -0,0 +1,120 @@ +module Test_UDsystem + + use funit + use ud2f_UDSystem, finalize_udunits_system => finalize, initialize_udunits_system => initialize + use udunits2f + use iso_c_binding, only: c_ptr, c_double, c_float, c_associated + + implicit none + + integer(ut_encoding), parameter :: ENCODING = UT_ASCII + character(len=*), parameter :: KM = 'km' + character(len=*), parameter :: M = 'm' + character(len=*), parameter :: S = 's' + +contains + + @Test + subroutine test_get_converter() + type(Converter) :: conv + type(c_ptr) :: cptr + integer(ut_status) :: status + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + call get_converter(conv, KM, M, rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to get converter') + @assertFalse(conv%is_free(), 'cv_converter is not set') + cptr = conv%get_cptr() + @assertTrue(c_associated(cptr), 'c_ptr is not associated') + + call conv%free() + call finalize_udunits_system() + + end subroutine test_get_converter + + @Test + subroutine test_convert_double() + real(c_double), parameter :: FROM = 1.0 + real(c_double), parameter :: EXPECTED = 1000.0 + real(c_double) :: actual + type(Converter) :: conv + integer(ut_status) :: status + character(len=*), parameter :: FROM_STRING = KM + character(len=*), parameter :: TO_STRING = M + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + call get_converter(conv, FROM_STRING, TO_STRING, rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to get converter') + actual = conv%convert(FROM) + @assertEqual(actual, EXPECTED, 'Actual does not equal expected.') + call conv%free() + call finalize_udunits_system() + + end subroutine test_convert_double + + @Test + subroutine test_convert_float() + real(c_float), parameter :: FROM = 1.0 + real(c_float), parameter :: EXPECTED = 1000.0 + real(c_float) :: actual + type(Converter) :: conv + integer(ut_status) :: status + character(len=*), parameter :: FROM_STRING = KM + character(len=*), parameter :: TO_STRING = M + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + call get_converter(conv, FROM_STRING, TO_STRING, rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to get converter') + actual = conv%convert(FROM) + @assertEqual(actual, EXPECTED, 'Actual does not equal expected.') + call conv%free() + call finalize_udunits_system() + + end subroutine test_convert_float + + @Test + subroutine test_convert_doubles() + real(c_double), parameter :: FROM(3) = [1.0, 2.0, 3.0] + real(c_double), parameter :: EXPECTED(3) = 1000.0 * FROM + real(c_double) :: actual(size(EXPECTED)) + type(Converter) :: conv + integer(ut_status) :: status + character(len=*), parameter :: FROM_STRING = KM + character(len=*), parameter :: TO_STRING = M + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + call get_converter(conv, FROM_STRING, TO_STRING, rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to get converter') + actual = conv%convert(FROM) + @assertEqual(actual, EXPECTED, 'Actual does not equal expected.') + call conv%free() + call finalize_udunits_system() + + end subroutine test_convert_doubles + + @Test + subroutine test_convert_floats() + real(c_float), parameter :: FROM(3) = [1.0, 2.0, 3.0] + real(c_float), parameter :: EXPECTED(3) = 1000.0 * FROM + real(c_float) :: actual(size(EXPECTED)) + type(Converter) :: conv + integer(ut_status) :: status + character(len=*), parameter :: FROM_STRING = KM + character(len=*), parameter :: TO_STRING = M + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + call get_converter(conv, FROM_STRING, TO_STRING, rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to get converter') + actual = conv%convert(FROM) + @assertEqual(actual, EXPECTED, 'Actual does not equal expected.') + call conv%free() + call finalize_udunits_system() + + end subroutine test_convert_floats + +end module Test_UDsystem diff --git a/udunits2f/tests/Test_udunits2f.pf b/udunits2f/tests/Test_udunits2f.pf new file mode 100644 index 000000000000..ec51c125b14c --- /dev/null +++ b/udunits2f/tests/Test_udunits2f.pf @@ -0,0 +1,167 @@ +module Test_udunits2f + + use funit + use ud2f_UDSystem, finalize_udunits_system => finalize, initialize_udunits_system => initialize + use udunits2f + use iso_c_binding, only: c_ptr, c_associated, c_char, c_null_char + + implicit none + + integer(ut_encoding), parameter :: ENCODING = UT_ASCII + character(len=*), parameter :: KM = 'km' + character(len=*), parameter :: M = 'm' + character(len=*), parameter :: S = 's' + +contains + + @Test + subroutine test_construct_system_no_path() + type(UDSystem) :: wrapper + + wrapper = UDSystem() + @assertFalse(wrapper%is_free(), 'ut_system is not set') + call ut_free_system(wrapper%get_cptr()) + + end subroutine test_construct_system_no_path + + @Test + subroutine test_cptr_wrapper() + type(UDSystem) :: wrapper + type(c_ptr) :: cptr + logical :: cassoc + + wrapper = UDSystem() + cptr = wrapper%get_cptr() + cassoc = c_associated(cptr) + @assertTrue(cassoc, 'Did not get c_ptr') + if(cassoc) then + @assertFalse(wrapper%is_free(), 'c_ptr should be set.') + call wrapper%free() + cptr = wrapper%get_cptr() + @assertFalse(c_associated(cptr), 'c_ptr should not be associated') + @assertTrue(wrapper%is_free(), 'c_ptr should not be set') + end if + if(c_associated(cptr)) call ut_free_system(cptr) + + end subroutine test_cptr_wrapper + + @Test + subroutine test_construct_unit() + type(UDUnit) :: unit1 + integer(ut_status) :: status + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + unit1 = UDUnit(KM) + @assertFalse(unit1%is_free(), 'ut_unit is not set (default encoding)') + + call unit1%free() + call finalize_udunits_system() + + end subroutine test_construct_unit + + @Test + subroutine test_construct_converter() + type(UDUnit) :: unit1 + type(UDUnit) :: unit2 + type(Converter) :: conv + integer(ut_status) :: status + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + unit1 = UDUnit(KM) + unit2 = UDUnit(M) + conv = Converter(unit1, unit2) + @assertFalse(conv%is_free(), 'cv_converter is not set') + + call unit1%free() + call unit2%free() + call conv%free() + call finalize_udunits_system() + + end subroutine test_construct_converter + + @Test + subroutine test_read_xml_nopath() + integer :: status + type(c_ptr) :: utsystem + + call read_xml(utsystem=utsystem, status=status) + if(.not. c_associated(utsystem)) then + @assertFalse(status == UT_OS, 'Operating system error') + @assertFalse(status == UT_PARSE_ERROR, 'Database file could not be parsed.') + @assertFalse(status == UT_OPEN_ARG, 'Non-null path could not be opened.') + @assertFalse(status == UT_OPEN_ENV, 'Environment variable is set but could not open.') + @assertFalse(status == UT_OPEN_DEFAULT, 'Default database could not be opened.') + end if + + call ut_free_system(utsystem) + + end subroutine test_read_xml_nopath + + @Test + subroutine test_cstring() + character(len=*), parameter :: fs = 'FOO_BAR' + character(kind=c_char, len=80) :: cchs + character(kind=kind(cchs)) :: cc + integer :: n + + cchs = cstring(fs) + @assertEqual(kind((cchs)), c_char, 'Wrong kind') + n = len_trim(cchs) + @assertEqual(n, len(fs)+1, 'cstring is incorrect length.') + cc = cchs(n:n) + @assertEqual(cc, c_null_char, 'Final character is not null.') + @assertEqual(cchs(1:(n-1)), fs, 'Initial characters do not match.') + + end subroutine test_cstring + + @Test + subroutine test_are_convertible() + type(UDUnit) :: unit1 + type(UDUnit) :: unit2 + integer(ut_status) :: status + logical :: convertible + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + unit1 = UDUnit(KM) + unit2 = UDUnit(M) + convertible = are_convertible(unit1, unit2, rc=status) + if(.not. convertible) then + @assertFalse(status == UT_BAD_ARG, 'One of the units is null.') + @assertFalse(status == UT_NOT_SAME_SYSTEM, 'Units belong to different systems.') + end if + + call unit1%free() + call unit2%free() + call finalize_udunits_system() + + end subroutine test_are_convertible + + @Test + subroutine test_are_not_convertible() + type(UDUnit) :: unit1 + type(UDUnit) :: unit2 + integer(ut_status) :: status + logical :: convertible + + call initialize_udunits_system(rc=status) + @assertEqual(UT_SUCCESS, status, 'Failed to initialize') + unit1 = UDUnit(KM) + unit2 = UDUnit(S) + convertible = are_convertible(unit1, unit2, rc=status) + @assertFalse(convertible, 'Units are not convertible.') + if(.not. convertible) then + @assertFalse(status == UT_BAD_ARG, 'One of the units is null.') + @assertFalse(status == UT_NOT_SAME_SYSTEM, 'Units belong to different systems.') + @assertTrue(status == UT_SUCCESS, 'Units are not convertible.') + end if + + call unit1%free() + call unit2%free() + call finalize_udunits_system() + + end subroutine test_are_not_convertible + +end module Test_udunits2f diff --git a/udunits2f/udunits2f.F90 b/udunits2f/udunits2f.F90 new file mode 100644 index 000000000000..e6d07b2ff8a2 --- /dev/null +++ b/udunits2f/udunits2f.F90 @@ -0,0 +1,6 @@ +module udunits2f + use ud2f_interfaces + use ud2f_encoding + use ud2f_status_codes + use ud2f_UDsystem +end module udunits2f diff --git a/udunits2f/ut_set_ignore_error_message_handler.c b/udunits2f/ut_set_ignore_error_message_handler.c new file mode 100644 index 000000000000..f20637a5140c --- /dev/null +++ b/udunits2f/ut_set_ignore_error_message_handler.c @@ -0,0 +1,16 @@ +#include +#include +#include "udunits2.h" + +/* Helper function to augment udunits2 error handling + * Sets the udunits2 error handler to ut_ignore + * which disables error messages from udunits2 + * udunits2 requires a ut_error_message_handler be passed + * into ut_set_error_message_handler to change the error handler, + * and ut_error_message_handler is a function with a variadic list + * of arguments, which is not possible in Fortran. +*/ +ut_error_message_handler ut_set_ignore_error_message_handler() +{ + return ut_set_error_message_handler(ut_ignore); +}