test_redist_repeat_parallel_f.f90

!
! Keywords:
! Maintainer: Jörg Behrens <behrens@dkrz.de>
!             Moritz Hanke <hanke@dkrz.de>
!             Thomas Jahns <jahns@dkrz.de>
! URL: https://doc.redmine.dkrz.de/yaxt/html/
!
! 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 DKRZ GmbH 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.
!
PROGRAM test_redist_repeat_parallel
  USE mpi
  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
  USE test_idxlist_utils, ONLY: test_err_count
  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xi => xt_int_kind, &
       xt_idxlist, xt_idxlist_delete, xt_stripe, &
       xt_idxfsection_new, xt_idxlist_collection_new, xt_idxstripes_new, &
       xt_xmap, xt_xmap_all2all_new, xt_xmap_delete, &
       xt_redist, xt_redist_p2p_new, xt_redist_repeat_new, &
       xt_redist_delete, xt_redist_s_exchange, &
       xt_idxlist_get_indices, xt_int_mpidt
    ! older PGI compilers do not handle generic interface correctly
#if defined __PGI
  USE xt_redist_int_i2, ONLY: xt_redist_s_exchange
  USE xt_redist_int_i4, ONLY: xt_redist_s_exchange
  USE xt_redist_int_i8, ONLY: xt_redist_s_exchange
#endif
  USE iso_c_binding, ONLY: c_int
  IMPLICIT NONE
  INTEGER :: comm_rank, comm_size, ierror
  CALL init_mpi
  CALL xt_initialize(mpi_comm_world)

  CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
  IF (ierror /= mpi_success) &
       CALL test_abort('mpi_comm_rank failed', &
       __file__, &
       __line__)
  CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
  IF (ierror /= mpi_success) &
       CALL test_abort('mpi_comm_size failed', &
       __file__, &
       __line__)

  IF (comm_size > 1) THEN
    CALL test_4redist
  END IF

  IF (test_err_count() /= 0) &
       CALL test_abort("non-zero error count!", &
       __file__, &
       __line__)
  CALL xt_finalize
  CALL finish_mpi
CONTAINS
  ! create index lists to exchange data sections from a global 4D
  ! array.
  !
  ! For the source side, the global array is of size W x X x Y x Z,
  ! where W=X=Y=comm_size and Z=2. The source data is decomposed
  ! into two shards of size comm_size*comm_size per process, where one
  ! shard is positioned at (1, comm_rank, 1, 1), the other at (1,
  ! comm_size-comm_rank, 1, 2), i.e. the decomposition of the last
  ! dimension is decomposed anti-symmetrically.
  !
  ! The destination decomposition is a contiguous subset of the
  ! interval [0,W*X*Y*Z-1], the stripe [S, S+2*comm_size^2] with S =
  ! comm_rank * 2 * comm_size**2. This corresponds to a section of a
  ! 4D array reshaped to [W,X,Z,Y], decomposed along the Y-axis
  ! according to comm_rank (but enumerated differently from source
  ! array).
  SUBROUTINE build_idxlists(indices_a, indices_b)
    TYPE(xt_idxlist), INTENT(out) :: indices_a, indices_b

    INTEGER, PARAMETER :: glob_rank = 4
    TYPE(xt_idxlist) :: indices_a_(2)
    INTEGER :: i
    INTEGER(xt_int_kind), PARAMETER :: start = 0
    INTEGER(xt_int_kind) :: global_size(glob_rank), local_start(glob_rank, 2)
    INTEGER :: local_size(glob_rank)

    TYPE(xt_stripe) :: stripe

    global_size(1) = int(comm_size, xi)
    global_size(2) = int(comm_size, xi)
    global_size(3) = int(comm_size, xi)
    global_size(4) = 2_xi
    local_size(1) = comm_size
    local_size(2) = 1
    local_size(3) = comm_size
    local_size(4) = 1
    local_start(1, 1) = 1_xi
    local_start(2, 1) = int(comm_rank + 1, xi)
    local_start(3, 1) = 1_xi
    local_start(4, 1) = 1_xi
    !
    local_start(1, 2) = 1_xi
    local_start(2, 2) = int(comm_size-comm_rank, xi)
    local_start(3, 2) = 1_xi
    local_start(4, 2) = 2_xi

    DO i = 1, 2
      indices_a_(i) = xt_idxfsection_new(start, global_size, local_size, &
           local_start(:, i))
    END DO
    indices_a = xt_idxlist_collection_new(indices_a_)

    CALL xt_idxlist_delete(indices_a_(1))
    CALL xt_idxlist_delete(indices_a_(2))

    stripe = xt_stripe(start = int(comm_rank * 2 * comm_size**2, xi), &
         &             stride = 1_xi, &
         &             nstrides = int(2*comm_size**2, c_int))
    indices_b = xt_idxstripes_new(stripe)
  END SUBROUTINE build_idxlists

  ! redist test for 4 level repetition of redist (i.e. 3D extension of 2D
  ! redist)
  SUBROUTINE test_4redist
    TYPE(xt_idxlist) :: indices_a, indices_b
    INTEGER(xt_int_kind) :: index_vector_a(2*comm_size**2), &
                            index_vector_b(2*comm_size**2)
    TYPE(xt_xmap) :: xmap
    TYPE(xt_redist) :: redist_repeat, redist_repeat_2, redist_p2p
    INTEGER(xt_int_kind) :: results_1(2*comm_size**2,4), &
                            results_2(2*comm_size**2,9)
    INTEGER(xt_int_kind) :: input_data(2*comm_size**2,9)
    INTEGER(xt_int_kind) :: ref_results_1(2*comm_size**2,4), &
                            ref_results_2(2*comm_size**2,9)
    INTEGER(mpi_address_kind) :: extent
    INTEGER(mpi_address_kind) :: base_address, temp_address
    INTEGER(c_int), PARAMETER :: &
         displacements(4) = (/ 0_c_int, 1_c_int, 2_c_int, 3_c_int /), &
         displacements_2(4) = (/ 1_c_int, 2_c_int, 4_c_int, 8_c_int /)
    INTEGER :: i, ierror
    INTEGER(xt_int_kind) :: j

    CALL build_idxlists(indices_a, indices_b)

    CALL xt_idxlist_get_indices(indices_a, index_vector_a)
    CALL xt_idxlist_get_indices(indices_b, index_vector_b)

    xmap = xt_xmap_all2all_new(indices_a, indices_b, mpi_comm_world)

    CALL xt_idxlist_delete(indices_a)
    CALL xt_idxlist_delete(indices_b)

    redist_p2p = xt_redist_p2p_new(xmap, xt_int_mpidt)
    CALL xt_xmap_delete(xmap)

    CALL mpi_get_address(input_data(1,1), base_address, ierror)
    CALL mpi_get_address(input_data(1,2), temp_address, ierror)
    extent = temp_address - base_address

    redist_repeat = xt_redist_repeat_new(redist_p2p, extent, extent, &
         4, displacements)
    redist_repeat_2 = xt_redist_repeat_new(redist_p2p, extent, extent, &
         4, displacements_2)

    CALL xt_redist_delete(redist_p2p)

    DO j = 1, 9
      DO i = 1, 2*comm_size**2
        input_data(i, j) = index_vector_a(i) + (j - 1_xi) * int(4*comm_size**2, xi)
      END DO
    END DO
    results_1 = -1
    results_2 = -1

    CALL xt_redist_s_exchange(redist_repeat, input_data, results_1)
    CALL xt_redist_s_exchange(redist_repeat_2, input_data, results_2)

    DO j = 1_xi, 4_xi
      DO i = 1, 2*comm_size**2
        ref_results_1(i, j) = index_vector_b(i) + (j - 1_xi) * int(4*comm_size**2, xi)
      END DO
    END DO
    DO j = 1, 9
      DO i = 1, 2*comm_size**2
        ref_results_2(i, j) = index_vector_b(i) + (j - 1_xi) * int(4*comm_size**2, xi)
      END DO
    END DO

    ref_results_2(:,1:4:3) = -1
    ref_results_2(:,6:8:1) = -1

    ! check results
    IF (any(results_1 /= ref_results_1)) &
         CALL test_abort("error on xt_redist_s_exchange", &
         __file__, &
         __line__)
    IF (any(results_2 /= ref_results_2)) &
         CALL test_abort("error on xt_redist_s_exchange", &
         __file__, &
         __line__)

    ! clean up

    CALL xt_redist_delete(redist_repeat)
    CALL xt_redist_delete(redist_repeat_2)
  END SUBROUTINE test_4redist

END PROGRAM test_redist_repeat_parallel
!
! Local Variables:
! f90-continuation-indent: 5
! coding: utf-8
! indent-tabs-mode: nil
! show-trailing-whitespace: t
! require-trailing-newline: t
! End:
!