UDSystem.F90 Source File

#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