mpi_types.f90

Go to the documentation of this file.

! Copyright (c) 2019-2023, The Neko Authors
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
!   * Redistributions of source code must retain the above copyright
!     notice, this list of conditions and the following disclaimer.
!
!   * Redistributions in binary form must reproduce the above
!     copyright notice, this list of conditions and the following
!     disclaimer in the documentation and/or other materials provided
!     with the distribution.
!
!   * Neither the name of the authors nor the names of its
!     contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module neko_mpi_types
  use comm
  use mpi_f08
  use re2, only : re2v1_xyz_t, re2v1_xy_t, re2v1_curve_t, re2v1_bc_t, &
       re2v2_xyz_t, re2v2_xy_t, re2v2_curve_t, re2v2_bc_t
  use nmsh, only : nmsh_quad_t, nmsh_hex_t, nmsh_zone_t, nmsh_curve_el_t
  use stl, only : stl_hdr_t, stl_triangle_t
  implicit none
  private
 
  type(mpi_datatype) :: mpi_nmsh_hex
  type(mpi_datatype) :: mpi_nmsh_quad
  type(mpi_datatype) :: mpi_nmsh_zone
  type(mpi_datatype) :: mpi_nmsh_curve
 
  type(mpi_datatype) :: mpi_re2v1_data_xyz
  type(mpi_datatype) :: mpi_re2v1_data_xy
  type(mpi_datatype) :: mpi_re2v1_data_cv
  type(mpi_datatype) :: mpi_re2v1_data_bc
 
  type(mpi_datatype) :: mpi_re2v2_data_xyz
  type(mpi_datatype) :: mpi_re2v2_data_xy
  type(mpi_datatype) :: mpi_re2v2_data_cv
  type(mpi_datatype) :: mpi_re2v2_data_bc
 
  type(mpi_datatype) :: mpi_stl_header
  type(mpi_datatype) :: mpi_stl_triangle
 
  integer :: mpi_real_size
  integer :: mpi_double_precision_size
  integer :: mpi_character_size
  integer :: mpi_integer_size
  integer :: mpi_logical_size
  integer :: mpi_real_prec_size
 
  ! Public derived types and size definitions
  public :: mpi_nmsh_hex, mpi_nmsh_quad, mpi_nmsh_zone, &
       mpi_nmsh_curve, &
       mpi_re2v1_data_xyz, mpi_re2v1_data_xy, &
       mpi_re2v1_data_cv, mpi_re2v1_data_bc, &
       mpi_re2v2_data_xyz, mpi_re2v2_data_xy, &
       mpi_re2v2_data_cv, mpi_re2v2_data_bc, &
       mpi_real_size, mpi_double_precision_size, &
       mpi_character_size, mpi_integer_size, &
       mpi_logical_size, mpi_real_prec_size, &
       mpi_stl_header, mpi_stl_triangle
 
  ! Public subroutines
  public :: neko_mpi_types_init, neko_mpi_types_free
 
contains
 
  subroutine neko_mpi_types_init
    integer :: ierr
 
    ! Define derived types
    call mpi_type_nmsh_hex_init
    call mpi_type_nmsh_quad_init
    call mpi_type_nmsh_zone_init
    call mpi_type_nmsh_curve_init
 
    call mpi_type_re2_xyz_init
    call mpi_type_re2_xy_init
    call mpi_type_re2_cv_init
    call mpi_type_re2_bc_init
 
    call mpi_type_stl_header_init
    call mpi_type_stl_triangle_init
 
    ! Check sizes of MPI types
    call mpi_type_size(mpi_real, mpi_real_size, ierr)
    call mpi_type_size(mpi_double_precision, mpi_double_precision_size, ierr)
    call mpi_type_size(mpi_character, mpi_character_size, ierr)
    call mpi_type_size(mpi_integer, mpi_integer_size, ierr)
    call mpi_type_size(mpi_logical, mpi_logical_size, ierr)
    call mpi_type_size(mpi_real_precision, mpi_real_prec_size, ierr)
 
    call mpi_barrier(neko_comm, ierr)
 
  end subroutine neko_mpi_types_init
 
  subroutine mpi_type_nmsh_hex_init
    type(nmsh_hex_t) :: nmsh_hex
    type(mpi_datatype) :: type(17)
    integer(kind=MPI_ADDRESS_KIND) :: disp(17), base
    integer :: len(17), i, ierr
 
    call mpi_get_address(nmsh_hex%el_idx, disp(1), ierr)
    call mpi_get_address(nmsh_hex%v(1)%v_idx, disp(2), ierr)
    call mpi_get_address(nmsh_hex%v(1)%v_xyz, disp(3), ierr)
    call mpi_get_address(nmsh_hex%v(2)%v_idx, disp(4), ierr)
    call mpi_get_address(nmsh_hex%v(2)%v_xyz, disp(5), ierr)
    call mpi_get_address(nmsh_hex%v(3)%v_idx, disp(6), ierr)
    call mpi_get_address(nmsh_hex%v(3)%v_xyz, disp(7), ierr)
    call mpi_get_address(nmsh_hex%v(4)%v_idx, disp(8), ierr)
    call mpi_get_address(nmsh_hex%v(4)%v_xyz, disp(9), ierr)
    call mpi_get_address(nmsh_hex%v(5)%v_idx, disp(10), ierr)
    call mpi_get_address(nmsh_hex%v(5)%v_xyz, disp(11), ierr)
    call mpi_get_address(nmsh_hex%v(6)%v_idx, disp(12), ierr)
    call mpi_get_address(nmsh_hex%v(6)%v_xyz, disp(13), ierr)
    call mpi_get_address(nmsh_hex%v(7)%v_idx, disp(14), ierr)
    call mpi_get_address(nmsh_hex%v(7)%v_xyz, disp(15), ierr)
    call mpi_get_address(nmsh_hex%v(8)%v_idx, disp(16), ierr)
    call mpi_get_address(nmsh_hex%v(8)%v_xyz, disp(17), ierr)
 
 
    base = disp(1)
    do i = 1, 17
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1) = 1
    len(2:16:2) = 1
    len(3:17:2) = 3
 
    type(1) = mpi_integer
    type(2:16:2) = mpi_integer
    type(3:17:2) = mpi_double_precision
    call mpi_type_create_struct(17, len, disp, type, mpi_nmsh_hex, ierr)
    call mpi_type_commit(mpi_nmsh_hex, ierr)
  end subroutine mpi_type_nmsh_hex_init
 
  subroutine mpi_type_nmsh_quad_init
    type(nmsh_quad_t) :: nmsh_quad
    type(mpi_datatype) :: type(9)
    integer(kind=MPI_ADDRESS_KIND) :: disp(9), base
    integer :: len(9), i, ierr
 
    call mpi_get_address(nmsh_quad%el_idx, disp(1), ierr)
    call mpi_get_address(nmsh_quad%v(1)%v_idx, disp(2), ierr)
    call mpi_get_address(nmsh_quad%v(1)%v_xyz, disp(3), ierr)
    call mpi_get_address(nmsh_quad%v(2)%v_idx, disp(4), ierr)
    call mpi_get_address(nmsh_quad%v(2)%v_xyz, disp(5), ierr)
    call mpi_get_address(nmsh_quad%v(3)%v_idx, disp(6), ierr)
    call mpi_get_address(nmsh_quad%v(3)%v_xyz, disp(7), ierr)
    call mpi_get_address(nmsh_quad%v(4)%v_idx, disp(8), ierr)
    call mpi_get_address(nmsh_quad%v(4)%v_xyz, disp(9), ierr)
 
 
    base = disp(1)
    do i = 1, 9
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1) = 1
    len(2:8:2) = 1
    len(3:9:2) = 3
 
    type(1) = mpi_integer
    type(2:8:2) = mpi_integer
    type(3:9:2) = mpi_double_precision
    call mpi_type_create_struct(9, len, disp, type, mpi_nmsh_quad, ierr)
    call mpi_type_commit(mpi_nmsh_quad, ierr)
  end subroutine mpi_type_nmsh_quad_init
 
  subroutine mpi_type_nmsh_zone_init
    type(nmsh_zone_t) :: nmsh_zone
    type(mpi_datatype) :: type(6)
    integer(kind=MPI_ADDRESS_KIND) :: disp(6), base
    integer :: len(6), i, ierr
 
    call mpi_get_address(nmsh_zone%e, disp(1), ierr)
    call mpi_get_address(nmsh_zone%f, disp(2), ierr)
    call mpi_get_address(nmsh_zone%p_e, disp(3), ierr)
    call mpi_get_address(nmsh_zone%p_f, disp(4), ierr)
    call mpi_get_address(nmsh_zone%glb_pt_ids, disp(5), ierr)
    call mpi_get_address(nmsh_zone%type, disp(6), ierr)
 
    base = disp(1)
    do i = 1, 6
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:4) = 1
    len(5) = 4
    len(6) = 1
    type = mpi_integer
 
    call mpi_type_create_struct(6, len, disp, type, mpi_nmsh_zone, ierr)
    call mpi_type_commit(mpi_nmsh_zone, ierr)
 
  end subroutine mpi_type_nmsh_zone_init
 
  subroutine mpi_type_nmsh_curve_init
    type(nmsh_curve_el_t) :: nmsh_curve_el
    type(mpi_datatype) :: type(3)
    integer(kind=MPI_ADDRESS_KIND) :: disp(3), base
    integer :: len(3), i, ierr
 
    call mpi_get_address(nmsh_curve_el%e, disp(1), ierr)
    call mpi_get_address(nmsh_curve_el%curve_data, disp(2), ierr)
    call mpi_get_address(nmsh_curve_el%type, disp(3), ierr)
 
    base = disp(1)
    do i = 1, 3
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1) = 1
    len(2) = 5*12
    len(3) = 12
    type(1) = mpi_integer
    type(2) = mpi_double_precision
    type(3) = mpi_integer
 
    call mpi_type_create_struct(3, len, disp, type, mpi_nmsh_curve, ierr)
    call mpi_type_commit(mpi_nmsh_curve, ierr)
 
  end subroutine mpi_type_nmsh_curve_init
 
 
  subroutine mpi_type_re2_xyz_init
    type(re2v1_xyz_t) :: re2v1_data
    type(re2v2_xyz_t) :: re2v2_data
    type(mpi_datatype) :: type(4)
    integer(kind=MPI_ADDRESS_KIND) :: disp(4), base
    integer :: len(4), ierr, i
 
    !
    ! Setup version 1
    !
 
    call mpi_get_address(re2v1_data%rgroup, disp(1), ierr)
    call mpi_get_address(re2v1_data%x, disp(2), ierr)
    call mpi_get_address(re2v1_data%y, disp(3), ierr)
    call mpi_get_address(re2v1_data%z, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len = 8
    len(1) = 1
    type = mpi_real
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v1_data_xyz, ierr)
    call mpi_type_commit(mpi_re2v1_data_xyz, ierr)
 
    !
    ! Setup version 2
    !
 
    call mpi_get_address(re2v2_data%rgroup, disp(1), ierr)
    call mpi_get_address(re2v2_data%x, disp(2), ierr)
    call mpi_get_address(re2v2_data%y, disp(3), ierr)
    call mpi_get_address(re2v2_data%z, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len = 8
    len(1) = 1
    type = mpi_double_precision
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v2_data_xyz, ierr)
    call mpi_type_commit(mpi_re2v2_data_xyz, ierr)
 
  end subroutine mpi_type_re2_xyz_init
 
  subroutine mpi_type_re2_xy_init
    type(re2v1_xy_t) :: re2v1_data
    type(re2v2_xy_t) :: re2v2_data
    type(mpi_datatype) :: type(3)
    integer(kind=MPI_ADDRESS_KIND) :: disp(3), base
    integer :: len(3), ierr, i
 
    !
    ! Setup version 1
    !
 
    call mpi_get_address(re2v1_data%rgroup, disp(1), ierr)
    call mpi_get_address(re2v1_data%x, disp(2), ierr)
    call mpi_get_address(re2v1_data%y, disp(3), ierr)
 
    base = disp(1)
    do i = 1, 3
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len = 4
    len(1) = 1
    type = mpi_real
 
    call mpi_type_create_struct(3, len, disp, type, mpi_re2v1_data_xy, ierr)
    call mpi_type_commit(mpi_re2v1_data_xy, ierr)
 
    !
    ! Setup version 2
    !
 
    call mpi_get_address(re2v2_data%rgroup, disp(1), ierr)
    call mpi_get_address(re2v2_data%x, disp(2), ierr)
    call mpi_get_address(re2v2_data%y, disp(3), ierr)
 
    base = disp(1)
    do i = 1, 3
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len = 4
    len(1) = 1
    type = mpi_double_precision
 
    call mpi_type_create_struct(3, len, disp, type, mpi_re2v2_data_xy, ierr)
    call mpi_type_commit(mpi_re2v2_data_xy, ierr)
 
  end subroutine mpi_type_re2_xy_init
 
  subroutine mpi_type_re2_cv_init
    type(re2v1_curve_t) :: re2v1_data
    type(re2v2_curve_t) :: re2v2_data
    type(mpi_datatype) :: type(4)
    integer(kind=MPI_ADDRESS_KIND) :: disp(4), base
    integer :: len(4), ierr, i
 
    !
    ! Setup version 1
    !
 
    call mpi_get_address(re2v1_data%elem, disp(1), ierr)
    call mpi_get_address(re2v1_data%zone, disp(2), ierr)
    call mpi_get_address(re2v1_data%point, disp(3), ierr)
    call mpi_get_address(re2v1_data%type, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:2) = 1
    len(3) = 5
    len(4) = 4
    type(1:2) = mpi_integer
    type(3) = mpi_real
    type(4) = mpi_character
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v1_data_cv, ierr)
    call mpi_type_commit(mpi_re2v1_data_cv, ierr)
 
    !
    ! Setup version 2
    !
 
    call mpi_get_address(re2v2_data%elem, disp(1), ierr)
    call mpi_get_address(re2v2_data%zone, disp(2), ierr)
    call mpi_get_address(re2v2_data%point, disp(3), ierr)
    call mpi_get_address(re2v2_data%type, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:2) = 1
    len(3) = 5
    len(4) = 8
    type(1:2) = mpi_double_precision
    type(3) = mpi_double_precision
    type(4) = mpi_character
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v2_data_cv, ierr)
    call mpi_type_commit(mpi_re2v2_data_cv, ierr)
 
  end subroutine mpi_type_re2_cv_init
 
  subroutine mpi_type_re2_bc_init
    type(re2v1_bc_t) :: re2v1_data
    type(re2v2_bc_t) :: re2v2_data
    type(mpi_datatype) :: type(4)
    integer(kind=MPI_ADDRESS_KIND) :: disp(4), base
    integer :: len(4), ierr, i
 
    !
    ! Setup version 1
    !
 
    call mpi_get_address(re2v1_data%elem, disp(1), ierr)
    call mpi_get_address(re2v1_data%face, disp(2), ierr)
    call mpi_get_address(re2v1_data%bc_data, disp(3), ierr)
    call mpi_get_address(re2v1_data%type, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:2) = 1
    len(3) = 5
    len(4) = 4
    type(1:2) = mpi_integer
    type(3) = mpi_real
    type(4) = mpi_character
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v1_data_bc, ierr)
    call mpi_type_commit(mpi_re2v1_data_bc, ierr)
 
    !
    ! Setup version 2
    !
 
    call mpi_get_address(re2v2_data%elem, disp(1), ierr)
    call mpi_get_address(re2v2_data%face, disp(2), ierr)
    call mpi_get_address(re2v2_data%bc_data, disp(3), ierr)
    call mpi_get_address(re2v2_data%type, disp(4), ierr)
 
    base = disp(1)
    do i = 1, 4
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:2) = 1
    len(3) = 5
    len(4) = 8
    type(1:2) = mpi_double_precision
    type(3) = mpi_double_precision
    type(4) = mpi_character
 
    call mpi_type_create_struct(4, len, disp, type, mpi_re2v2_data_bc, ierr)
    call mpi_type_commit(mpi_re2v2_data_bc, ierr)
 
  end subroutine mpi_type_re2_bc_init
 
  subroutine mpi_type_stl_header_init
    type(stl_hdr_t) :: stl_hdr
    type(mpi_datatype) :: type(2)
    integer(kind=MPI_ADDRESS_KIND) :: disp(2), base
    integer :: len(2), ierr, i
 
    call mpi_get_address(stl_hdr%hdr, disp(1), ierr)
    call mpi_get_address(stl_hdr%ntri, disp(2), ierr)
 
    base = disp(1)
    do i = 1, 2
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1) = 80
    len(2) = 1
 
    type(1) = mpi_character
    type(2) = mpi_integer
 
    call mpi_type_create_struct(2, len, disp, type, mpi_stl_header, ierr)
    call mpi_type_commit(mpi_stl_header, ierr)
 
  end subroutine mpi_type_stl_header_init
 
  subroutine mpi_type_stl_triangle_init
    type(stl_triangle_t) :: tri
    type(mpi_datatype) :: type(5)
    integer(kind=MPI_ADDRESS_KIND) :: disp(5), base
    integer :: len(5), i, ierr
 
    call mpi_get_address(tri%n, disp(1), ierr)
    call mpi_get_address(tri%v1, disp(2), ierr)
    call mpi_get_address(tri%v2, disp(3), ierr)
    call mpi_get_address(tri%v3, disp(4), ierr)
    call mpi_get_address(tri%attrib, disp(5), ierr)
 
    base = disp(1)
    do i = 1, 5
       disp(i) = mpi_aint_diff(disp(i), base)
    end do
 
    len(1:4) = 3
    len(5) = 1
 
    type(1:4) = mpi_real
    type(5) = mpi_integer2
 
    call mpi_type_create_struct(5, len, disp, type, mpi_stl_triangle, ierr)
    call mpi_type_commit(mpi_stl_triangle, ierr)
 
  end subroutine mpi_type_stl_triangle_init
 
  subroutine neko_mpi_types_free
    call mpi_type_nmsh_hex_free
    call mpi_type_nmsh_quad_free
    call mpi_type_nmsh_zone_free
    call mpi_type_nmsh_curve_free
    call mpi_type_re2_xyz_free
    call mpi_type_re2_xy_free
    call mpi_type_re2_bc_free
    call mpi_type_stl_header_free
    call mpi_type_stl_triangle_free
  end subroutine neko_mpi_types_free
 
  subroutine mpi_type_nmsh_hex_free
    integer ierr
    call mpi_type_free(mpi_nmsh_hex, ierr)
  end subroutine mpi_type_nmsh_hex_free
 
  subroutine mpi_type_nmsh_quad_free
    integer ierr
    call mpi_type_free(mpi_nmsh_quad, ierr)
  end subroutine mpi_type_nmsh_quad_free
 
  subroutine mpi_type_nmsh_zone_free
    integer ierr
    call mpi_type_free(mpi_nmsh_zone, ierr)
  end subroutine mpi_type_nmsh_zone_free
 
  subroutine mpi_type_nmsh_curve_free
    integer ierr
    call mpi_type_free(mpi_nmsh_curve, ierr)
  end subroutine mpi_type_nmsh_curve_free
 
  subroutine mpi_type_re2_xyz_free
    integer ierr
    call mpi_type_free(mpi_re2v1_data_xyz, ierr)
    call mpi_type_free(mpi_re2v2_data_xyz, ierr)
  end subroutine mpi_type_re2_xyz_free
 
  subroutine mpi_type_re2_xy_free
    integer ierr
    call mpi_type_free(mpi_re2v1_data_xy, ierr)
    call mpi_type_free(mpi_re2v2_data_xy, ierr)
  end subroutine mpi_type_re2_xy_free
 
  subroutine mpi_type_re2_cv_free
    integer ierr
    call mpi_type_free(mpi_re2v1_data_cv, ierr)
    call mpi_type_free(mpi_re2v2_data_cv, ierr)
  end subroutine mpi_type_re2_cv_free
 
  subroutine mpi_type_re2_bc_free
    integer ierr
    call mpi_type_free(mpi_re2v1_data_bc, ierr)
    call mpi_type_free(mpi_re2v2_data_bc, ierr)
  end subroutine mpi_type_re2_bc_free
 
  subroutine mpi_type_stl_header_free
    integer ierr
    call mpi_type_free(mpi_stl_header, ierr)
  end subroutine mpi_type_stl_header_free
 
  subroutine mpi_type_stl_triangle_free
    integer ierr
    call mpi_type_free(mpi_stl_triangle, ierr)
  end subroutine mpi_type_stl_triangle_free
end module neko_mpi_types