pfunit_comm_utils.F90

Go to the documentation of this file.

module pfunit_comm_utils
  use mpi
  use comm, only : neko_comm, neko_global_comm, mpi_real_precision, &
       mpi_extra_precision, pe_rank, pe_size, nio, global_pe_rank, &
       global_pe_size, neko_mpi_thread_provided
  use utils, only : neko_error
  implicit none
  private
 
  logical :: comm_test_active = .false.
 
  interface comm_init_test
     module procedure comm_init_test_f
  end interface comm_init_test
 
  public :: comm_init_test, comm_free_test
 
  interface
     subroutine neko_comm_wrapper_init(fcomm) &
          bind(c, name='neko_comm_wrapper_init')
       use, intrinsic :: iso_c_binding, only : c_int
       integer(c_int), value :: fcomm
     end subroutine neko_comm_wrapper_init
  end interface
 
contains
 
  subroutine comm_init_test_f(ext_comm)
    integer, intent(in) :: ext_comm
    integer :: ierr
 
    call comm_test_precheck()
    if (ext_comm .eq. mpi_comm_null) then
       call neko_error('Cannot initialize test communicator from MPI_COMM_NULL')
    end if
 
#ifndef HAVE_MPI_PARAM_DTYPE
    mpi_real_precision%mpi_val = mpi_double_precision
    mpi_extra_precision%mpi_val = mpi_double_precision
#endif
 
    call mpi_comm_dup(ext_comm, neko_global_comm%mpi_val, ierr)
    if (ierr .ne. mpi_success) then
       call neko_error('Failed to duplicate test global communicator')
    end if
    call mpi_comm_dup(ext_comm, neko_comm%mpi_val, ierr)
    if (ierr .ne. mpi_success) then
       call neko_error('Failed to duplicate test communicator')
    end if
    call comm_test_set_state()
  end subroutine comm_init_test_f
 
  subroutine comm_free_test
    integer :: ierr
    logical :: initialized, finalized
 
    if (.not. comm_test_active) return
 
    call mpi_initialized(initialized, ierr)
    call comm_test_check(ierr, 'Failed to query MPI initialization state')
    call mpi_finalized(finalized, ierr)
    call comm_test_check(ierr, 'Failed to query MPI finalization state')
    if ((.not. initialized) .or. finalized) then
       call neko_error('MPI is not active during comm_free_test')
    end if
 
    call mpi_barrier(neko_comm%mpi_val, ierr)
    call comm_test_check(ierr, 'Failed to synchronize test communicator')
    call mpi_comm_free(neko_comm%mpi_val, ierr)
    call comm_test_check(ierr, 'Failed to free test communicator')
    call mpi_comm_free(neko_global_comm%mpi_val, ierr)
    call comm_test_check(ierr, 'Failed to free test global communicator')
 
    call neko_comm_wrapper_init(mpi_comm_null)
    pe_rank = -1
    pe_size = 0
    global_pe_rank = -1
    global_pe_size = 0
    nio = .false.
    comm_test_active = .false.
  end subroutine comm_free_test
 
  subroutine comm_test_precheck()
    integer :: ierr
    logical :: initialized, finalized
 
    if (comm_test_active) then
       call neko_error('Test communicator is already initialized')
    end if
 
    call mpi_initialized(initialized, ierr)
    call comm_test_check(ierr, 'Failed to query MPI initialization state')
    if (.not. initialized) then
       call neko_error('MPI must be initialized before comm_init_test')
    end if
 
    call mpi_finalized(finalized, ierr)
    call comm_test_check(ierr, 'Failed to query MPI finalization state')
    if (finalized) then
       call neko_error('MPI is finalized before comm_init_test')
    end if
 
    call mpi_query_thread(neko_mpi_thread_provided, ierr)
    call comm_test_check(ierr, 'Failed to query MPI thread support')
  end subroutine comm_test_precheck
 
  subroutine comm_test_set_state()
    integer :: ierr
 
    call mpi_comm_rank(neko_global_comm%mpi_val, global_pe_rank, ierr)
    call comm_test_check(ierr, 'Failed to query test global rank')
    call mpi_comm_size(neko_global_comm%mpi_val, global_pe_size, ierr)
    call comm_test_check(ierr, 'Failed to query test global size')
    call mpi_comm_rank(neko_comm%mpi_val, pe_rank, ierr)
    call comm_test_check(ierr, 'Failed to query test rank')
    call mpi_comm_size(neko_comm%mpi_val, pe_size, ierr)
    call comm_test_check(ierr, 'Failed to query test size')
 
    nio = .false.
    call neko_comm_wrapper_init(neko_comm%mpi_val)
    comm_test_active = .true.
  end subroutine comm_test_set_state
 
  subroutine comm_test_check(ierr, msg)
    integer, intent(in) :: ierr
    character(len=*), intent(in) :: msg
 
    if (ierr .ne. mpi_success) call neko_error(msg)
  end subroutine comm_test_check
 
end module pfunit_comm_utils