datautils.F90

Go to the documentation of this file.

module data_utils_mod
  use datadefn_mod, only : double_precision, single_precision, string_length
  use conversions_mod, only : conv_to_integer, conv_to_string, conv_is_integer
  use collections_mod, only : map_type, c_get_integer, c_get_string, c_get_generic, c_put_string, c_contains
  use io_server_client_mod, only : integer_data_type, boolean_data_type, string_data_type, float_data_type, &
       double_data_type
  use configuration_parser_mod, only : io_configuration_type
  use logging_mod, only : log_error, log_log
  implicit none

#ifndef TEST_MODE
  private
#endif

  integer, parameter :: array_step_threshold=204800

  public is_field_present, get_map, get_map_from_monc, get_scalar_integer, get_scalar_integer_from_monc, get_scalar_logical, &
       get_scalar_logical_from_monc, get_scalar_real, get_scalar_real_from_monc, get_array_double, get_array_double_from_monc, &
       get_3darray_double, get_3darray_double_from_monc, get_4darray_double, get_4darray_double_from_monc, get_2darray_double, &
       get_2darray_double_from_monc, get_array_integer, get_array_integer_from_monc, &
       get_string, get_string_from_monc, get_field_size, get_action_attribute_string, get_action_attribute_logical, &
       get_action_attribute_integer, unpack_scalar_integer_from_bytedata, unpack_scalar_real_from_bytedata, &
       unpack_scalar_dp_real_from_bytedata, unpack_scalar_logical_from_bytedata, unpack_scalar_string_from_bytedata
contains

  integer function unpack_scalar_integer_from_bytedata(data, start_point)
    character, dimension(:), intent(in) :: data
    integer, intent(inout) :: start_point

    unpack_scalar_integer_from_bytedata=transfer(data(start_point:start_point+&
         kind(unpack_scalar_integer_from_bytedata)-1), unpack_scalar_integer_from_bytedata)
    start_point=start_point+kind(unpack_scalar_integer_from_bytedata)
  end function unpack_scalar_integer_from_bytedata

  logical function unpack_scalar_logical_from_bytedata(data, start_point)
    character, dimension(:), intent(in) :: data
    integer, intent(inout) :: start_point

    unpack_scalar_logical_from_bytedata=transfer(data(start_point:start_point+&
         kind(unpack_scalar_logical_from_bytedata)-1), unpack_scalar_logical_from_bytedata)
    start_point=start_point+kind(unpack_scalar_logical_from_bytedata)
  end function unpack_scalar_logical_from_bytedata

  character(len=STRING_LENGTH) function unpack_scalar_string_from_bytedata(data, start_point)
    character, dimension(:), intent(in) :: data
    integer, intent(inout) :: start_point

    unpack_scalar_string_from_bytedata=transfer(data(start_point:start_point+string_length-1), unpack_scalar_string_from_bytedata)
    start_point=start_point+string_length
  end function unpack_scalar_string_from_bytedata

  real function unpack_scalar_real_from_bytedata(data, start_point)
    character, dimension(:), intent(in) :: data
    integer, intent(inout) :: start_point

    unpack_scalar_real_from_bytedata=transfer(data(start_point:start_point+&
         kind(unpack_scalar_real_from_bytedata)-1), unpack_scalar_real_from_bytedata)
    start_point=start_point+kind(unpack_scalar_real_from_bytedata)
  end function unpack_scalar_real_from_bytedata

  real(kind=DOUBLE_PRECISION) function unpack_scalar_dp_real_from_bytedata(data, start_point)
    character, dimension(:), intent(in) :: data
    integer, intent(inout) :: start_point

    unpack_scalar_dp_real_from_bytedata=transfer(data(start_point:start_point+&
         kind(unpack_scalar_dp_real_from_bytedata)-1), unpack_scalar_dp_real_from_bytedata)
    start_point=start_point+kind(unpack_scalar_dp_real_from_bytedata)
  end function unpack_scalar_dp_real_from_bytedata

  character(len=STRING_LENGTH) function get_action_attribute_string(action_attributes, field_name)
    type(map_type), intent(inout) :: action_attributes
    character(len=*), intent(in) :: field_name

    if (.not. c_contains(action_attributes, field_name)) call log_log(log_error, &
         "You must provide the field name in the collective operation configuration")

    get_action_attribute_string=c_get_string(action_attributes, field_name)
  end function get_action_attribute_string

  integer function get_action_attribute_integer(action_attributes, field_name)
    type(map_type), intent(inout) :: action_attributes
    character(len=*), intent(in) :: field_name

    character(len=STRING_LENGTH) :: str_val

    str_val=get_action_attribute_string(action_attributes, field_name)
    if (.not. conv_is_integer(str_val)) call log_log(log_error, "Can not convert string '"//trim(str_val)//"' to an integer")
    get_action_attribute_integer=conv_to_integer(str_val)
  end function get_action_attribute_integer

  logical function get_action_attribute_logical(action_attributes, field_name)
    type(map_type), intent(inout) :: action_attributes
    character(len=*), intent(in) :: field_name

    if (c_contains(action_attributes, field_name)) then
      get_action_attribute_logical=trim(c_get_string(action_attributes, field_name)) .eq. "true"
    else
      get_action_attribute_logical=.false.
    end if
  end function get_action_attribute_logical

  !! Allows one to check if an optional field is present in the data being provided by a MONC
  !! process or not
  !! @param io_configuration Configuration of the IO server
  !! @param source PID of the MONC process
  !! @param data_id The ID of the data definition that is represented by the dump
  !! @param key Key of the field to retrieve
  !! @returns Whether the field is present or not
  logical function is_field_present(io_configuration, source, data_id, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character(len=*), intent(in) :: key

    integer :: start_index, end_index, monc_location
    class(*), pointer :: generic

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    generic=>c_get_generic(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), key)
    if (.not. associated(generic)) then
      is_field_present=.false.
      return
    end if
    start_index=conv_to_integer(generic, .false.)
    generic=>c_get_generic(io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), key)
    if (.not. associated(generic)) then
      is_field_present=.false.
      return
    end if
    end_index=conv_to_integer(generic, .false.)

    is_field_present = end_index .gt. start_index
  end function is_field_present

  integer function get_field_size(field_starts, field_ends, key, data_type)
    type(map_type), intent(inout) :: field_starts, field_ends
    character(len=*), intent(in) :: key
    integer, intent(in) :: data_type

    integer :: start_index, end_index, element_size
    real(kind=DOUBLE_PRECISION) :: dreal
    real(kind=SINGLE_PRECISION) :: sreal

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    if (data_type == integer_data_type) then
      element_size=kind(start_index)
    else if (data_type == double_data_type) then
      element_size=kind(dreal)
    else if (data_type == float_data_type) then
      element_size=kind(sreal)
    else if (data_type == string_data_type) then
      element_size=string_length
    end if
    get_field_size=((end_index-start_index)+1)/element_size
  end function get_field_size

  type(map_type) function get_map(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    
    integer :: start_index, end_index, elements, i
    character(len=STRING_LENGTH) :: retrieved1, retrieved2

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    elements = (end_index+1 - start_index) / (string_length*2)

    do i=1, elements
      retrieved1=transfer(data_dump(start_index:start_index+string_length-1), retrieved1)
      start_index=start_index+string_length
      retrieved2=transfer(data_dump(start_index:start_index+string_length-1), retrieved2)
      start_index=start_index+string_length
      call c_put_string(get_map, retrieved1, retrieved2)
    end do    
  end function get_map  

  type(map_type) function get_map_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_map_from_monc=get_map(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_map_from_monc

  function get_string(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    character(len=STRING_LENGTH) :: get_string

    integer :: start_index, end_index

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    get_string=transfer(data_dump(start_index:end_index), get_string)
  end function get_string

  function get_string_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    character(len=STRING_LENGTH) :: get_string_from_monc

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_string_from_monc=get_string(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_string_from_monc  

  logical function get_scalar_logical(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: start_index, end_index

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    get_scalar_logical=transfer(data_dump(start_index:end_index), get_scalar_logical)
  end function get_scalar_logical

  logical function get_scalar_logical_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_scalar_logical_from_monc=get_scalar_logical(&
         io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_scalar_logical_from_monc

  integer function get_scalar_integer(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: start_index, end_index

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    get_scalar_integer=transfer(data_dump(start_index:end_index), get_scalar_integer)
  end function get_scalar_integer

  integer function get_scalar_integer_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_scalar_integer_from_monc=get_scalar_integer(&
         io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_scalar_integer_from_monc

  real(kind=DOUBLE_PRECISION) function get_scalar_real(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: start_index, end_index

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    get_scalar_real=transfer(data_dump(start_index:end_index), get_scalar_real)
  end function get_scalar_real

  real(kind=DOUBLE_PRECISION) function get_scalar_real_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_scalar_real_from_monc=get_scalar_real(&
         io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_scalar_real_from_monc

  function get_array_double(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:), allocatable :: get_array_double

    integer :: start_index, end_index, elements, start_e, end_e, current_start_index, current_end_index

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    elements = ceiling((end_index - start_index) / real(kind(get_array_double)))

    allocate(get_array_double(elements))
    if (elements .ge. array_step_threshold) then 
       current_start_index=start_index
       do while (current_start_index .lt. end_index)
          current_end_index=current_start_index+array_step_threshold-1
          if (current_end_index .gt. end_index) current_end_index=end_index
          start_e=((current_start_index-start_index)/kind(get_array_double))+1
          end_e=ceiling((current_end_index-start_index)/real(kind(get_array_double)))
          get_array_double(start_e:end_e)=transfer(data_dump(current_start_index:current_end_index), get_array_double)
          current_start_index=current_start_index+array_step_threshold
       end do
    else
       get_array_double=transfer(data_dump(start_index:end_index), get_array_double, elements)
    end if
  end function get_array_double

  function get_array_double_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:), allocatable :: get_array_double_from_monc

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_array_double_from_monc=get_array_double(&
         io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)
  end function get_array_double_from_monc

  function get_array_integer(field_starts, field_ends, data_dump, key)
    type(map_type), intent(inout) :: field_starts, field_ends
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    integer, dimension(:), allocatable :: get_array_integer

    integer :: start_index, end_index, elements

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    elements = (end_index - start_index) / kind(get_array_integer)

    allocate(get_array_integer(elements))
    get_array_integer=transfer(data_dump(start_index:end_index), get_array_integer)
  end function get_array_integer  

  function get_array_integer_from_monc(io_configuration, source, data_id, data_dump, key)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    integer, dimension(:), allocatable :: get_array_integer_from_monc

    integer ::  monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    get_array_integer_from_monc=get_array_integer(&
         io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key)   
  end function get_array_integer_from_monc

  subroutine get_2darray_double_from_monc(io_configuration, source, data_id, data_dump, key, target_data, size1, size2)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id, size1, size2
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:), pointer, contiguous, intent(inout) :: target_data

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    call get_2darray_double(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key, target_data, &
         size1, size2)    
  end subroutine get_2darray_double_from_monc

  subroutine get_2darray_double(field_starts, field_ends, data_dump, key, target_data, size1, size2)
    type(map_type), intent(inout) :: field_starts, field_ends
    integer, intent(in) ::  size1, size2
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:), pointer, contiguous, intent(inout) :: target_data

    integer :: start_index, end_index, element_size
    real(kind=DOUBLE_PRECISION), dimension(:), pointer :: temp_data

    ! Pointer bounds remapping as transfer needs 1D array but for performance don't want to allocate another array and copy using reshape
    temp_data(1:size1*size2)=>target_data

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    element_size=(end_index-start_index) / kind(target_data)

    temp_data=transfer(data_dump(start_index:end_index), temp_data)
  end subroutine get_2darray_double

  subroutine get_3darray_double(field_starts, field_ends, data_dump, key, target_data, size1, size2, size3)
    type(map_type), intent(inout) :: field_starts, field_ends
    integer, intent(in) ::  size1, size2, size3
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:,:), pointer, contiguous, intent(inout) :: target_data
    
    integer :: start_index, end_index, element_size
    real(kind=DOUBLE_PRECISION), dimension(:), pointer :: temp_data

    ! Pointer bounds remapping as transfer needs 1D array but for performance don't want to allocate another array and copy using reshape
    temp_data(1:size1*size2*size3)=>target_data

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    element_size=(end_index-start_index) / kind(target_data)
    
    temp_data=transfer(data_dump(start_index:end_index), temp_data)
  end subroutine get_3darray_double  

  subroutine get_3darray_double_from_monc(io_configuration, source, data_id, data_dump, key, target_data, size1, size2, size3)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id, size1, size2, size3
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:,:), pointer, contiguous, intent(inout) :: target_data

    integer :: monc_location

    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    call get_3darray_double(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key, target_data, &
         size1, size2, size3)    
  end subroutine get_3darray_double_from_monc

  subroutine get_4darray_double(field_starts, field_ends, data_dump, key, target_data, size1, size2, size3, size4)
    type(map_type), intent(inout) :: field_starts, field_ends
    integer, intent(in) :: size1, size2, size3, size4
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:,:,:), pointer, contiguous, intent(inout) :: target_data

    integer :: start_index, end_index, element_size
    real(kind=DOUBLE_PRECISION), dimension(:), pointer :: temp_data
    
    ! Pointer bounds remapping as transfer needs 1D array but for performance don't want to allocate another array and copy using reshape
    temp_data(1:size1*size2*size3*size4)=>target_data     

    if (.not. c_contains(field_starts, key) .or. .not. c_contains(field_ends, key)) &
         call log_log(log_error, "Field name `"//key//"` not found in the data definition")

    start_index=c_get_integer(field_starts, key)
    end_index=c_get_integer(field_ends, key)

    element_size=(end_index-start_index) / kind(target_data)
    
    temp_data=transfer(data_dump(start_index:end_index), temp_data)
  end subroutine get_4darray_double  
  
  subroutine get_4darray_double_from_monc(io_configuration, source, data_id, data_dump, key, target_data, size1, &
       size2, size3, size4)
    type(io_configuration_type), intent(inout) :: io_configuration
    integer, intent(in) :: source, data_id, size1, size2, size3, size4
    character, dimension(:), allocatable, intent(in) :: data_dump
    character(len=*), intent(in) :: key
    real(kind=DOUBLE_PRECISION), dimension(:,:,:,:), pointer, contiguous, intent(inout) :: target_data

    integer :: monc_location
    
    monc_location=c_get_integer(io_configuration%monc_to_index, conv_to_string(source))

    call get_4darray_double(io_configuration%registered_moncs(monc_location)%field_start_locations(data_id), &
         io_configuration%registered_moncs(monc_location)%field_end_locations(data_id), data_dump, key, target_data, &
         size1, size2, size3, size4)    
  end subroutine get_4darray_double_from_monc  
end module data_utils_mod