ioclient.F90

Go to the documentation of this file.

module io_server_client_mod
  use datadefn_mod, only : default_precision, single_precision, double_precision, string_length
  use collections_mod, only : hashmap_type, iterator_type, mapentry_type, c_get_iterator, c_has_next, &
       c_next_mapentry, c_get_generic
  use conversions_mod, only : conv_to_string
  use mpi, only : mpi_character, mpi_int, mpi_logical, mpi_real, mpi_double_precision, mpi_address_kind
  implicit none

#ifndef TEST_MODE
  private
#endif

  
  type data_sizing_description_type
     character(len=STRING_LENGTH) :: field_name
     integer :: dimensions, dim_sizes(4)
  end type data_sizing_description_type

  type field_description_type
     character(len=STRING_LENGTH) :: definition_name, field_name
     integer :: field_type, data_type
     logical :: optional
  end type field_description_type

  type definition_description_type
     character(len=STRING_LENGTH) :: definition_name
     logical :: send_on_terminate
     integer :: number_fields, frequency
  end type definition_description_type  

  ! Constants used in sending and receiving IO data
  integer, parameter :: command_tag=9, data_tag=10, register_command=1, deregister_command=3, data_command_start=4, &
       inter_io_communication=2

  
  integer, parameter :: scalar_field_type = 1, array_field_type=2, map_field_type=3
  
  integer, parameter :: integer_data_type = 1, boolean_data_type=2, string_data_type=3, float_data_type=4, &
       double_data_type=5

  character(len=STRING_LENGTH), parameter :: local_sizes_key="local_sizes", local_start_points_key="local_start_points", &
       local_end_points_key="local_end_points", number_q_indicies_key="num_q_indicies"

  public command_tag, data_tag, register_command, deregister_command, data_command_start, inter_io_communication, &
       scalar_field_type, array_field_type, map_field_type, integer_data_type, boolean_data_type, &
       string_data_type, float_data_type, local_sizes_key, local_start_points_key, local_end_points_key, number_q_indicies_key, &
       double_data_type, data_sizing_description_type, populate_mpi_type_extents, append_mpi_datatype, &
       get_mpi_datatype_from_internal_representation, definition_description_type, field_description_type, &
       build_mpi_type_data_sizing_description, build_mpi_type_field_description, build_mpi_type_definition_description, &
       pack_scalar_field, pack_array_field, pack_map_field, get_data_description_from_name

contains

  function populate_mpi_type_extents()
    integer :: populate_mpi_type_extents(5)

    integer :: ierr
    integer(kind=MPI_ADDRESS_KIND) :: large_number_extents(5)
    
    call mpi_type_extent(mpi_int, large_number_extents(integer_data_type), ierr)
    call mpi_type_extent(mpi_logical, large_number_extents(boolean_data_type), ierr)
    call mpi_type_extent(mpi_character, large_number_extents(string_data_type), ierr)
    call mpi_type_extent(mpi_real, large_number_extents(float_data_type), ierr)
    call mpi_type_extent(mpi_double_precision, large_number_extents(double_data_type), ierr)

    populate_mpi_type_extents=int(large_number_extents)
  end function populate_mpi_type_extents  

  integer function build_mpi_type_definition_description()
    integer :: new_type, ierr, block_counts(4), old_types(4), offsets(4)
    integer(MPI_ADDRESS_KIND) :: num_addr, base_addr

    type(definition_description_type) :: basic_type

    call mpi_get_address(basic_type, base_addr, ierr)
    old_types(1) = mpi_character
    block_counts(1) = string_length
    offsets(1)=0

    call mpi_get_address(basic_type%send_on_terminate, num_addr, ierr)
    old_types(2) = mpi_logical
    block_counts(2) = 1
    offsets(2)=int(num_addr-base_addr)

    call mpi_get_address(basic_type%number_fields, num_addr, ierr)
    old_types(3) = mpi_int
    block_counts(3) = 1
    offsets(3)=int(num_addr-base_addr)

    call mpi_get_address(basic_type%frequency, num_addr, ierr)
    old_types(4) = mpi_int
    block_counts(4) = 1
    offsets(4)=int(num_addr-base_addr)

    call mpi_type_struct(4, block_counts, offsets, old_types, new_type, ierr) 
    call mpi_type_commit(new_type, ierr)
    build_mpi_type_definition_description=new_type
  end function build_mpi_type_definition_description

  integer function build_mpi_type_field_description()
    integer :: new_type, ierr, old_types(5), block_counts(5), offsets(5)
    integer(MPI_ADDRESS_KIND) :: num_addr, base_addr

    type(field_description_type) :: basic_type

    call mpi_get_address(basic_type, base_addr, ierr)    
    old_types(1) = mpi_character
    block_counts(1) = string_length
    offsets(1)=0

    call mpi_get_address(basic_type%field_name, num_addr, ierr)    
    old_types(2) = mpi_character
    block_counts(2) = string_length
    offsets(2)=int(num_addr-base_addr)

    call mpi_get_address(basic_type%field_type, num_addr, ierr)
    old_types(3) = mpi_int
    block_counts(3) = 1
    offsets(3)=int(num_addr-base_addr)
    
    call mpi_get_address(basic_type%data_type, num_addr, ierr)
    old_types(4) = mpi_int
    block_counts(4) = 1
    offsets(4)=int(num_addr-base_addr)

    call mpi_get_address(basic_type%optional, num_addr, ierr)
    old_types(5) = mpi_logical
    block_counts(5) = 1
    offsets(5)=int(num_addr-base_addr)

    call mpi_type_struct(5, block_counts, offsets, old_types, new_type, ierr) 
    call mpi_type_commit(new_type, ierr)
    build_mpi_type_field_description=new_type
  end function build_mpi_type_field_description

  integer function build_mpi_type_data_sizing_description()
    integer :: new_type, ierr, block_counts(3), old_types(3), offsets(3)
    integer(kind=MPI_ADDRESS_KIND) :: num_addr, base_addr

    type(data_sizing_description_type) :: basic_type

    call mpi_get_address(basic_type, base_addr, ierr)
    old_types(1) = mpi_character
    block_counts(1) = string_length 
    offsets(1)=0

    call mpi_get_address(basic_type%dimensions, num_addr, ierr)
    old_types(2) = mpi_int
    block_counts(2) = 1
    offsets(2)=int(num_addr-base_addr)

    call mpi_get_address(basic_type%dim_sizes, num_addr, ierr)    
    old_types(3) = mpi_int
    block_counts(3) = 4
    offsets(3)=int(num_addr-base_addr)

    call mpi_type_struct(3, block_counts, offsets, old_types, new_type, ierr) 
    call mpi_type_commit(new_type, ierr)
    build_mpi_type_data_sizing_description=new_type
  end function build_mpi_type_data_sizing_description

  subroutine append_mpi_datatype(field_start, field_end, field_array_sizes, data_type, &
       type_extents, prev_data_type, type_index, old_types, offsets, block_counts)
    integer, intent(in) :: field_start, field_end, field_array_sizes, data_type, type_index, prev_data_type, type_extents(5)
    integer, intent(inout) :: old_types(20), offsets(20), block_counts(20)

    block_counts(type_index)=(field_end-field_start) + 1 + field_array_sizes
    old_types(type_index)=get_mpi_datatype_from_internal_representation(data_type)
    if (type_index == 1) then
      offsets(1)=0
    else
      offsets(type_index)=offsets(type_index-1)+type_extents(prev_data_type) * block_counts(type_index-1)
    end if    
  end subroutine append_mpi_datatype

  integer function get_mpi_datatype_from_internal_representation(type_code)
    integer, intent(in) :: type_code

    if (type_code==integer_data_type) then
      get_mpi_datatype_from_internal_representation=mpi_int
    else if (type_code==boolean_data_type) then
      get_mpi_datatype_from_internal_representation=mpi_logical
    else if (type_code==string_data_type) then
      get_mpi_datatype_from_internal_representation=mpi_character
    else if (type_code==float_data_type) then
      get_mpi_datatype_from_internal_representation=mpi_real
    else if (type_code==double_data_type) then
      get_mpi_datatype_from_internal_representation=mpi_double_precision
    end if
  end function get_mpi_datatype_from_internal_representation

  integer function pack_map_field(buffer, start_offset, map_to_pack)
    character, dimension(:), intent(inout) :: buffer
    integer, intent(in) :: start_offset
    type(hashmap_type) :: map_to_pack

    integer :: i, target_end, current_offset
    character(len=STRING_LENGTH) :: temp_string
    character(len=STRING_LENGTH), pointer :: sized_raw_character
    class(*), pointer :: raw_data, raw_to_string
    type(iterator_type) :: map_iterator
    type(mapentry_type) :: specific_mapentry

    current_offset=start_offset
    map_iterator=c_get_iterator(map_to_pack)
    do while (c_has_next(map_iterator))
      specific_mapentry=c_next_mapentry(map_iterator)
      temp_string=specific_mapentry%key
      target_end=current_offset+string_length-1
      buffer(current_offset:target_end)=transfer(temp_string, buffer(current_offset:target_end))
      current_offset=target_end+1

      raw_data=>c_get_generic(specific_mapentry)
      raw_to_string=>raw_data
      select type (raw_data)
      type is(integer)
        temp_string=conv_to_string(raw_data)
      type is(real(4))
        temp_string=conv_to_string(raw_data)
      type is (real(8))
        temp_string=conv_to_string(raw_data)
      type is(logical)
        temp_string=conv_to_string(raw_data)
      type is(character(len=*))
        sized_raw_character=>conv_to_string(raw_to_string, .false., string_length)
        temp_string=sized_raw_character
      end select
      target_end=current_offset+string_length-1
      buffer(current_offset:target_end)=transfer(temp_string, buffer(current_offset:target_end))
      current_offset=target_end+1
    end do
    pack_map_field=current_offset
  end function pack_map_field

  integer function pack_array_field(buffer, start_offset, int_array, real_array_1d, real_array_2d, real_array_3d, real_array_4d)
    character, dimension(:), intent(inout) :: buffer
    integer, intent(in) :: start_offset
    integer, dimension(:), intent(in), optional :: int_array
    real(kind=DEFAULT_PRECISION), dimension(:), intent(in), optional :: real_array_1d
    real(kind=DEFAULT_PRECISION), dimension(:,:), intent(in), optional :: real_array_2d
    real(kind=DEFAULT_PRECISION), dimension(:,:,:), intent(in), optional :: real_array_3d
    real(kind=DEFAULT_PRECISION), dimension(:,:,:,:), intent(in), optional :: real_array_4d

    integer :: target_end

    if (present(int_array)) then
      target_end=start_offset+kind(int_array)*size(int_array)-1    
      buffer(start_offset:target_end) = transfer(int_array, buffer(start_offset:target_end))
    else if (present(real_array_1d)) then
      target_end=start_offset+kind(real_array_1d)*size(real_array_1d)-1    
      buffer(start_offset:target_end) = transfer(real_array_1d, buffer(start_offset:target_end))
    else if (present(real_array_2d)) then
      target_end=start_offset+kind(real_array_2d)*size(real_array_2d)-1    
      buffer(start_offset:target_end) = transfer(real_array_2d, buffer(start_offset:target_end))
    else if (present(real_array_3d)) then
      target_end=start_offset+kind(real_array_3d)*size(real_array_3d)-1    
      buffer(start_offset:target_end) = transfer(real_array_3d, buffer(start_offset:target_end))
    else if (present(real_array_4d)) then
      target_end=start_offset+kind(real_array_4d)*size(real_array_4d)-1    
      buffer(start_offset:target_end) = transfer(real_array_4d, buffer(start_offset:target_end))
    end if
    pack_array_field=target_end+1
  end function pack_array_field

  integer function pack_scalar_field(buffer, start_offset, int_value, real_value, single_real_value, double_real_value, &
       string_value, logical_value)
    character, dimension(:), intent(inout) :: buffer
    integer, intent(in) :: start_offset
    integer, intent(in), optional :: int_value
    real(kind=DEFAULT_PRECISION), intent(in), optional :: real_value
    real(kind=SINGLE_PRECISION), intent(in), optional :: single_real_value
    real(kind=DOUBLE_PRECISION), intent(in), optional :: double_real_value
    character(len=*), intent(in), optional :: string_value
    logical, intent(in), optional :: logical_value

    integer :: target_end
    character(len=STRING_LENGTH) :: string_to_insert

    if (present(int_value)) then
      target_end=start_offset+kind(int_value)-1
      buffer(start_offset:target_end) = transfer(int_value, buffer(start_offset:target_end))
    else if (present(real_value)) then
      target_end=start_offset+kind(real_value)-1
      buffer(start_offset:target_end) = transfer(real_value, buffer(start_offset:target_end))
    else if (present(single_real_value)) then
      target_end=start_offset+kind(single_real_value)-1
      buffer(start_offset:target_end) = transfer(single_real_value, buffer(start_offset:target_end))
    else if (present(double_real_value)) then
      target_end=start_offset+kind(double_real_value)-1
      buffer(start_offset:target_end) = transfer(double_real_value, buffer(start_offset:target_end))
    else if (present(string_value)) then
      target_end=start_offset+string_length-1
      string_to_insert=string_value
      buffer(start_offset:target_end) = transfer(string_to_insert, buffer(start_offset:target_end))
    else if (present(logical_value)) then
      target_end=start_offset+kind(logical_value)-1
      buffer(start_offset:target_end) = transfer(logical_value, buffer(start_offset:target_end))
    else 
      target_end=start_offset-1
    end if
    pack_scalar_field=target_end+1
  end function pack_scalar_field

  logical function get_data_description_from_name(descriptions, name, field_description)
    type(data_sizing_description_type), dimension(:), intent(in) :: descriptions
    type(data_sizing_description_type), intent(out), optional :: field_description
    character(len=*), intent(in) :: name

    integer :: i
    do i=1,size(descriptions)
      if (descriptions(i)%field_name == name) then
        if (present(field_description)) field_description=descriptions(i)
        get_data_description_from_name=.true.
        return
      end if
    end do
    get_data_description_from_name=.false.
  end function get_data_description_from_name
end module io_server_client_mod