test_redist_common_f.f90 22.7 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
!>
!! @file test_redist_common_f.f90
!! @brief common routines for Fortran test of redist classes
!!
!! @copyright Copyright  (C)  2013 Jörg Behrens <behrens@dkrz.de>
!!                                 Moritz Hanke <hanke@dkrz.de>
!!                                 Thomas Jahns <jahns@dkrz.de>
!!
!! @author Jörg Behrens <behrens@dkrz.de>
!!         Moritz Hanke <hanke@dkrz.de>
!!         Thomas Jahns <jahns@dkrz.de>
!!

!
! Keywords:
! Maintainer: Jörg Behrens <behrens@dkrz.de>
!             Moritz Hanke <hanke@dkrz.de>
!             Thomas Jahns <jahns@dkrz.de>
Moritz Hanke's avatar
Moritz Hanke committed
19
! URL: https://doc.redmine.dkrz.de/yaxt/html/
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
!
! 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.
!
MODULE test_redist_common
49
  USE xt_core, ONLY: i2, i4, i8
50
  USE iso_c_binding, ONLY: c_loc, c_int, c_char, c_null_char
51 52
  USE mpi
  USE yaxt, ONLY: xt_idxlist, xt_int_kind, xt_idxvec_new, xt_idxlist_delete, &
53 54
       xt_xmap, xt_xmap_all2all_new, xt_redist, xt_redist_msg, xt_redist_copy, &
       xt_redist_single_array_base_new, xt_redist_delete, &
55
       xt_redist_s_exchange, xt_redist_s_exchange1, &
56
       xt_redist_a_exchange1, xt_redist_get_mpi_comm, &
57
       xt_request, xt_request_wait, xt_request_test, xt_is_null, &
58
       xt_redist_get_num_recv_msg, xt_redist_get_num_send_msg, &
59 60
       xi => xt_int_kind, xt_config, xt_config_new, &
       xt_config_set_exchange_method
61 62 63 64
#ifdef __PGI
  ! PGI up to at least 15.4 has a bug that prevents proper import of
  ! multiply extended generics. This is a separate bug from the one exhibited
  ! in 12.7 and older (see test_xmap_intersection_parallel_f.f90 for that)
65 66 67 68
  USE xt_redist_real_dp, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
  USE xt_redist_int_i2, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
  USE xt_redist_int_i4, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
  USE xt_redist_int_i8, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
69 70 71 72 73 74 75 76
#endif
#if defined(__GNUC__) && __GNUC__ < 4 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 4)
  ! gfortran 4.4 botches default initialization for xt_request
  USE xt_requests, ONLY: xt_request_init
  USE iso_c_binding, ONLY: c_null_ptr
#  define REQ_DEFAULT_INIT_FIXUP(req) CALL xt_request_init(req, c_null_ptr)
#else
#  define REQ_DEFAULT_INIT_FIXUP(req)
77
#endif
Thomas Jahns's avatar
Thomas Jahns committed
78
  USE ftest_common, ONLY: test_abort, cmp_arrays
79 80
  IMPLICIT NONE
  PRIVATE
81 82
  INTERFACE check_redist
    MODULE PROCEDURE check_redist_dp
Thomas Jahns's avatar
Thomas Jahns committed
83 84 85 86
    MODULE PROCEDURE check_redist_dp_i2
    MODULE PROCEDURE check_redist_dp_i4
    MODULE PROCEDURE check_redist_dp_i8
    MODULE PROCEDURE check_redist_dp_2d
87
    MODULE PROCEDURE check_redist_xi
88 89 90
    MODULE PROCEDURE check_redist_i2
    MODULE PROCEDURE check_redist_i4
    MODULE PROCEDURE check_redist_i8
91
  END INTERFACE check_redist
92 93 94 95 96 97 98 99 100

  INTERFACE wrap_a_exchange
    MODULE PROCEDURE wrap_a_exchange_dp
    MODULE PROCEDURE wrap_a_exchange_dp2d
    MODULE PROCEDURE wrap_a_exchange_i2
    MODULE PROCEDURE wrap_a_exchange_i4
    MODULE PROCEDURE wrap_a_exchange_i8
  END INTERFACE wrap_a_exchange

101 102 103 104 105 106 107 108
  INTERFACE test_redist_single_array_base
    MODULE PROCEDURE test_redist_single_array_base_dp
  END INTERFACE test_redist_single_array_base

  INTERFACE check_redist_extended
    MODULE PROCEDURE check_redist_extended_dp
  END INTERFACE check_redist_extended

109
  PUBLIC :: build_odd_selection_xmap, check_redist, communicators_are_congruent
110
  PUBLIC :: check_wait_request, check_test_request, check_redist_xi
111
  PUBLIC :: test_redist_single_array_base
112
  PUBLIC :: redist_exchanger_option
113

114
  CHARACTER(len=*), PARAMETER :: filename = 'test_redist_common_f.f90'
115

116 117 118 119
CONTAINS
  ! build xmap for destination list containing all odd elements of
  ! source list dimensioned 1 to src_slice_len
  FUNCTION build_odd_selection_xmap(src_slice_len) RESULT(xmap)
120
    INTEGER, INTENT(in) :: src_slice_len
121
    TYPE(xt_xmap) :: xmap
122 123
    INTEGER :: i, j, dst_slice_len
    INTEGER, PARAMETER :: dst_step = 2
124 125 126
    INTEGER(xt_int_kind), ALLOCATABLE :: index_list(:)
    TYPE(xt_idxlist) :: src_idxlist, dst_idxlist

127
    dst_slice_len = (src_slice_len + dst_step - 1)/dst_step
128
    ALLOCATE(index_list(src_slice_len))
129 130
    DO i = 1, src_slice_len
      index_list(i) = INT(i, xt_int_kind)
131 132
    END DO
    src_idxlist = xt_idxvec_new(index_list)
133 134 135 136
    j = 1
    DO i = 1, src_slice_len, dst_step
      index_list(j) = INT(i, xt_int_kind)
      j = j + 1
137 138 139 140
    END DO
    dst_idxlist = xt_idxvec_new(index_list, dst_slice_len)
    DEALLOCATE(index_list)

141
    xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
142 143 144 145
    CALL xt_idxlist_delete(src_idxlist)
    CALL xt_idxlist_delete(dst_idxlist)
  END FUNCTION build_odd_selection_xmap

146 147 148 149 150 151 152 153 154 155
  FUNCTION communicators_are_congruent(comm1, comm2) RESULT(congruent)
    INTEGER, INTENT(in) :: comm1, comm2
    LOGICAL :: congruent

    INTEGER :: ierror, rcode

    CALL mpi_comm_compare(comm1, comm2, rcode, ierror)
    congruent = ((rcode == mpi_ident) .OR. (rcode == mpi_congruent))
  END FUNCTION communicators_are_congruent

Thomas Jahns's avatar
Thomas Jahns committed
156
  SUBROUTINE assert_request_is_null(request, file, line)
157
    TYPE(xt_request), INTENT(in) :: request
Thomas Jahns's avatar
Thomas Jahns committed
158 159 160 161 162 163 164 165 166 167
    INTEGER, INTENT(in) :: line
    CHARACTER(len=*), INTENT(in) :: file
    IF (.NOT. xt_is_null(request)) &
      CALL test_abort("error: expected null request", &
           file, line)
  END SUBROUTINE assert_request_is_null

  SUBROUTINE assert_request_is_not_null(request, file, line)
    TYPE(xt_request), INTENT(in) :: request
    INTEGER, INTENT(in) :: line
168
    CHARACTER(len=*), INTENT(in) :: file
Thomas Jahns's avatar
Thomas Jahns committed
169 170
    IF (xt_is_null(request)) &
      CALL test_abort("error: expected non-null request", &
171
           file, line)
Thomas Jahns's avatar
Thomas Jahns committed
172
  END SUBROUTINE assert_request_is_not_null
173 174 175 176 177

  SUBROUTINE check_wait_request(request, file, line)
    TYPE(xt_request), INTENT(inout) :: request
    CHARACTER(len=*), INTENT(in) :: file
    INTEGER, INTENT(in) :: line
Thomas Jahns's avatar
Thomas Jahns committed
178
    CALL assert_request_is_not_null(request, file, line)
179
    CALL xt_request_wait(request)
Thomas Jahns's avatar
Thomas Jahns committed
180
    CALL assert_request_is_null(request, file, line)
181 182
  END SUBROUTINE check_wait_request

183 184 185 186
  SUBROUTINE check_test_request(request, file, line)
    TYPE(xt_request), INTENT(inout) :: request
    CHARACTER(len=*), INTENT(in) :: file
    INTEGER, INTENT(in) :: line
187
    LOGICAL :: flag
188
    CALL xt_request_test(request, flag)
189 190
    IF (xt_is_null(request) .AND. .NOT. flag) &
        CALL test_abort("error: expected flag set to .true.", file, line)
191 192
  END SUBROUTINE check_test_request

193
  SUBROUTINE wrap_a_exchange_dp(redist, src, dst)
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
    TYPE(xt_redist), INTENT(in) :: redist
    DOUBLE PRECISION, TARGET, INTENT(in) :: src(:)
    DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
    DOUBLE PRECISION, TARGET :: dummy(1)
    DOUBLE PRECISION, POINTER :: src_p(:), dst_p(:)

    IF (SIZE(src) > 0) THEN
      src_p => src
    ELSE
      src_p => dummy
    END IF
    IF (SIZE(dst) > 0) THEN
      dst_p => dst
    ELSE
      dst_p => dummy
    END IF
    CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
  END SUBROUTINE wrap_a_exchange_dp

  SUBROUTINE wrap_a_exchange_dp_as(redist, src, dst)
214 215 216 217 218 219 220 221 222
    TYPE(xt_redist), INTENT(in) :: redist
    DOUBLE PRECISION, TARGET, INTENT(in) :: src(*)
    DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(*)
    TYPE(xt_request) :: request

    REQ_DEFAULT_INIT_FIXUP(request)
    CALL assert_request_is_null(request, filename, __LINE__)
    CALL xt_redist_a_exchange1(redist, C_LOC(src), C_LOC(dst), request)
    CALL check_wait_request(request, filename, __LINE__)
223
    CALL check_test_request(request, filename, __LINE__)
224
  END SUBROUTINE wrap_a_exchange_dp_as
225 226 227

  SUBROUTINE wrap_a_exchange_dp2d(redist, src, dst)
    TYPE(xt_redist), INTENT(in) :: redist
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
    DOUBLE PRECISION, TARGET, INTENT(in) :: src(:,:)
    DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:,:)
    DOUBLE PRECISION, TARGET :: dummy(1,1)
    DOUBLE PRECISION, POINTER :: src_p(:,:), dst_p(:,:)
    IF (SIZE(src) > 0) THEN
      src_p => src
    ELSE
      src_p => dummy
    END IF
    IF (SIZE(dst) > 0) THEN
      dst_p => dst
    ELSE
      dst_p => dummy
    END IF
    CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
243 244 245
  END SUBROUTINE wrap_a_exchange_dp2d

  SUBROUTINE wrap_a_exchange_i2(redist, src, dst)
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i2), TARGET, INTENT(in) :: src(:)
    INTEGER(i2), TARGET, INTENT(inout) :: dst(:)
    INTEGER(i2), TARGET :: dummy(1)
    INTEGER(i2), POINTER :: src_p(:), dst_p(:)
    IF (SIZE(src) > 0) THEN
      src_p => src
    ELSE
      src_p => dummy
    END IF
    IF (SIZE(dst) > 0) THEN
      dst_p => dst
    ELSE
      dst_p => dummy
    END IF
    CALL wrap_a_exchange_i2_as(redist, src_p, dst_p)
  END SUBROUTINE wrap_a_exchange_i2

  SUBROUTINE wrap_a_exchange_i2_as(redist, src, dst)
265 266 267 268 269 270 271 272 273
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i2), TARGET, INTENT(in) :: src(*)
    INTEGER(i2), TARGET, INTENT(inout) :: dst(*)
    TYPE(xt_request) :: request

    REQ_DEFAULT_INIT_FIXUP(request)
    CALL assert_request_is_null(request, filename, __LINE__)
    CALL xt_redist_a_exchange1(redist, C_LOC(src), C_LOC(dst), request)
    CALL check_wait_request(request, filename, __LINE__)
274
    CALL check_test_request(request, filename, __LINE__)
275
  END SUBROUTINE wrap_a_exchange_i2_as
276 277

  SUBROUTINE wrap_a_exchange_i4(redist, src, dst)
278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i4), TARGET, INTENT(in) :: src(:)
    INTEGER(i4), TARGET, INTENT(inout) :: dst(:)
    INTEGER(I4), TARGET :: dummy(1)
    INTEGER(I4), POINTER :: src_p(:), dst_p(:)

    IF (SIZE(src) > 0) THEN
      src_p => src
    ELSE
      src_p => dummy
    END IF
    IF (SIZE(dst) > 0) THEN
      dst_p => dst
    ELSE
      dst_p => dummy
    END IF
    CALL wrap_a_exchange_i4_as(redist, src_p, dst_p)
  END SUBROUTINE wrap_a_exchange_i4

  SUBROUTINE wrap_a_exchange_i4_as(redist, src, dst)
298 299 300 301 302 303 304 305 306
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i4), TARGET, INTENT(in) :: src(*)
    INTEGER(i4), TARGET, INTENT(inout) :: dst(*)
    TYPE(xt_request) :: request

    REQ_DEFAULT_INIT_FIXUP(request)
    CALL assert_request_is_null(request, filename, __LINE__)
    CALL xt_redist_a_exchange1(redist, C_LOC(src), C_LOC(dst), request)
    CALL check_wait_request(request, filename, __LINE__)
307
    CALL check_test_request(request, filename, __LINE__)
308
  END SUBROUTINE wrap_a_exchange_i4_as
309 310

  SUBROUTINE wrap_a_exchange_i8(redist, src, dst)
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i8), TARGET, INTENT(in) :: src(:)
    INTEGER(i8), TARGET, INTENT(inout) :: dst(:)
    INTEGER(I8), TARGET :: dummy(1)
    INTEGER(I8), POINTER :: src_p(:), dst_p(:)

    IF (SIZE(src) > 0) THEN
      src_p => src
    ELSE
      src_p => dummy
    END IF
    IF (SIZE(dst) > 0) THEN
      dst_p => dst
    ELSE
      dst_p => dummy
    END IF
    CALL wrap_a_exchange_i8_as(redist, src_p, dst_p)
  END SUBROUTINE wrap_a_exchange_i8

  SUBROUTINE wrap_a_exchange_i8_as(redist, src, dst)
331 332 333 334 335 336 337 338 339
    TYPE(xt_redist), INTENT(in) :: redist
    INTEGER(i8), TARGET, INTENT(in) :: src(*)
    INTEGER(i8), TARGET, INTENT(inout) :: dst(*)
    TYPE(xt_request) :: request

    REQ_DEFAULT_INIT_FIXUP(request)
    CALL assert_request_is_null(request, filename, __LINE__)
    CALL xt_redist_a_exchange1(redist, C_LOC(src), C_LOC(dst), request)
    CALL check_wait_request(request, filename, __LINE__)
340
    CALL check_test_request(request, filename, __LINE__)
341
  END SUBROUTINE wrap_a_exchange_i8_as
342

Thomas Jahns's avatar
Thomas Jahns committed
343
  SUBROUTINE check_redist_dp(redist, src, dst, ref_dst)
344
    TYPE(xt_redist), INTENT(in) :: redist
345 346
    DOUBLE PRECISION, INTENT(in) :: src(:), ref_dst(:)
    DOUBLE PRECISION, INTENT(inout) :: dst(:)
347
    INTEGER :: dst_size, ref_dst_size, iexch
348

349 350
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
351
    IF (dst_size /= ref_dst_size) &
352
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
353 354 355 356 357
    DO iexch = 1, 2
      dst = -1.0d0
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
358
        CALL wrap_a_exchange(redist, src, dst)
359 360
      ENDIF
      IF (cmp_arrays(dst, ref_dst)) &
361
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
362
    ENDDO
Thomas Jahns's avatar
Thomas Jahns committed
363
  END SUBROUTINE check_redist_dp
364

Thomas Jahns's avatar
Thomas Jahns committed
365
  SUBROUTINE check_redist_dp_i2(redist, src, dst, ref_dst)
366
    TYPE(xt_redist), INTENT(in) :: redist
367
    DOUBLE PRECISION, INTENT(in) :: src(:)
368
    INTEGER(i2), INTENT(in) :: ref_dst(:)
369
    DOUBLE PRECISION, INTENT(inout) :: dst(:)
370
    INTEGER :: dst_size, ref_dst_size, iexch
371

372 373 374
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
    IF (dst_size /= ref_dst_size) &
375
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
376 377 378 379 380
    DO iexch = 1, 2
      dst = -1.0d0
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
381
        CALL wrap_a_exchange(redist, src, dst)
382 383
      ENDIF
      IF (cmp_arrays(dst, DBLE(ref_dst))) &
384
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
385
    ENDDO
Thomas Jahns's avatar
Thomas Jahns committed
386
  END SUBROUTINE check_redist_dp_i2
387

Thomas Jahns's avatar
Thomas Jahns committed
388
  SUBROUTINE check_redist_dp_i4(redist, src, dst, ref_dst)
389
    TYPE(xt_redist), INTENT(in) :: redist
390
    DOUBLE PRECISION, INTENT(in) :: src(:)
391
    INTEGER(i4), INTENT(in) :: ref_dst(:)
392
    DOUBLE PRECISION, INTENT(inout) :: dst(:)
393
    INTEGER :: dst_size, ref_dst_size, iexch
394

395 396 397
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
    IF (dst_size /= ref_dst_size) &
398
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
399 400 401 402 403
    DO iexch = 1, 2
      dst = -1.0d0
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
404
        CALL wrap_a_exchange(redist, src, dst)
405 406
      ENDIF
      IF (cmp_arrays(dst, DBLE(ref_dst))) &
407
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
408
    ENDDO
Thomas Jahns's avatar
Thomas Jahns committed
409
  END SUBROUTINE check_redist_dp_i4
410

Thomas Jahns's avatar
Thomas Jahns committed
411
  SUBROUTINE check_redist_dp_i8(redist, src, dst, ref_dst)
412
    TYPE(xt_redist), INTENT(in) :: redist
413
    DOUBLE PRECISION, INTENT(in) :: src(:)
414
    INTEGER(i8), INTENT(in) :: ref_dst(:)
415
    DOUBLE PRECISION, INTENT(inout) :: dst(:)
416
    INTEGER :: dst_size, ref_dst_size, iexch
417

418 419 420
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
    IF (dst_size /= ref_dst_size) &
421
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
422 423 424 425 426
    DO iexch = 1, 2
      dst = -1.0d0
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
427
        CALL wrap_a_exchange(redist, src, dst)
428 429
      ENDIF
      IF (cmp_arrays(dst, DBLE(ref_dst))) &
430
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
431
    ENDDO
Thomas Jahns's avatar
Thomas Jahns committed
432
  END SUBROUTINE check_redist_dp_i8
433

Thomas Jahns's avatar
Thomas Jahns committed
434
  SUBROUTINE check_redist_dp_2d(redist, src, dst, ref_dst)
435
    TYPE(xt_redist), INTENT(in) :: redist
436 437
    DOUBLE PRECISION, INTENT(in) :: src(:,:), ref_dst(:,:)
    DOUBLE PRECISION, INTENT(inout) :: dst(:,:)
438
    INTEGER :: dst_size, ref_dst_size, iexch
439

440 441
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
442
    IF (dst_size /= ref_dst_size) &
443
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
444 445 446 447 448
    DO iexch = 1, 2
      dst = -1.0d0
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
449
        CALL wrap_a_exchange(redist, src, dst)
450 451 452 453 454
      ENDIF
      IF (cmp_arrays(dst, ref_dst)) &
           CALL test_abort("error in xt_redist_s_exchange1", &
           filename, __LINE__)
    ENDDO
Thomas Jahns's avatar
Thomas Jahns committed
455
  END SUBROUTINE check_redist_dp_2d
456

457
  SUBROUTINE check_redist_xi(redist, src_size, src, dst_size, dst, ref_dst)
458
    TYPE(xt_redist), INTENT(in) :: redist
459 460
    INTEGER, INTENT(in) :: src_size, dst_size
    INTEGER(xi), TARGET, INTENT(in) :: src(src_size)
461 462
    INTEGER(xi), INTENT(in) :: ref_dst(dst_size)
    INTEGER(xi), TARGET, INTENT(inout) :: dst(dst_size)
463
    CALL check_redist(redist, src, dst, ref_dst)
464 465
  END SUBROUTINE check_redist_xi

466 467
  SUBROUTINE check_redist_i2(redist, src, dst, ref_dst)
    TYPE(xt_redist), INTENT(in) :: redist
468 469
    INTEGER(i2), INTENT(in) :: src(:), ref_dst(:)
    INTEGER(i2), INTENT(inout) :: dst(:)
470
    INTEGER :: dst_size, ref_dst_size, iexch
471

472 473 474
    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
    IF (dst_size /= ref_dst_size) &
475
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
476 477 478 479 480
    DO iexch = 1, 2
      dst = -1_i2
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
481
        CALL wrap_a_exchange(redist, src, dst)
482 483
      ENDIF
      IF (cmp_arrays(dst, ref_dst)) &
484
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
485
    ENDDO
486 487 488 489
  END SUBROUTINE check_redist_i2

  SUBROUTINE check_redist_i4(redist, src, dst, ref_dst)
    TYPE(xt_redist), INTENT(in) :: redist
490 491
    INTEGER(i4), INTENT(in) :: src(:), ref_dst(:)
    INTEGER(i4), INTENT(inout) :: dst(:)
492
    INTEGER :: dst_size, ref_dst_size, iexch
493 494 495 496

    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
    IF (dst_size /= ref_dst_size) &
497
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
498 499 500 501 502
    DO iexch = 1, 2
      dst = -1_i4
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
503
        CALL wrap_a_exchange(redist, src, dst)
504 505
      ENDIF
      IF (cmp_arrays(dst, ref_dst)) &
506
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
507
    ENDDO
508 509 510
  END SUBROUTINE check_redist_i4

  SUBROUTINE check_redist_i8(redist, src, dst, ref_dst)
511
    TYPE(xt_redist), INTENT(in) :: redist
512 513
    INTEGER(i8), INTENT(in) :: src(:), ref_dst(:)
    INTEGER(i8), INTENT(inout) :: dst(:)
514
    INTEGER :: dst_size, ref_dst_size, iexch
515 516 517

    dst_size = SIZE(dst)
    ref_dst_size = SIZE(ref_dst)
518
    IF (dst_size /= ref_dst_size) &
519
         CALL test_abort("error: ref_dst larger than dst", filename, __LINE__)
520 521 522 523 524
    DO iexch = 1, 2
      dst = -1_i8
      IF (iexch == 1) THEN
        CALL xt_redist_s_exchange(redist, src, dst)
      ELSE
525
        CALL wrap_a_exchange(redist, src, dst)
526 527
      ENDIF
      IF (cmp_arrays(dst, ref_dst)) &
528
           CALL test_abort("error in xt_redist_s_exchange1", filename, __LINE__)
529
    ENDDO
530
  END SUBROUTINE check_redist_i8
531

532
  SUBROUTINE test_redist_single_array_base_dp( &
533
      send_msgs, recv_msgs, src_data, ref_dst_data, comm, config)
534 535 536 537 538
    TYPE(xt_redist_msg), INTENT(in) :: send_msgs(:)
    TYPE(xt_redist_msg), INTENT(in) :: recv_msgs(:)
    DOUBLE PRECISION, INTENT(in) :: src_data(:)
    DOUBLE PRECISION, INTENT(in) :: ref_dst_data(:)
    INTEGER, INTENT(in) :: comm
539
    TYPE(xt_config), INTENT(in) :: config
540 541 542 543 544

    TYPE(xt_redist) :: redist
    INTEGER :: nsend, nrecv

    redist = &
545
      xt_redist_single_array_base_new(send_msgs, recv_msgs, comm, config)
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
    nsend = SIZE(send_msgs)
    IF (nsend /= xt_redist_get_num_send_msg(redist)) &
         CALL test_abort("error in xt_redist_get_num_send_msg", &
         filename, __LINE__)
    nrecv = SIZE(recv_msgs)
    IF (nrecv /= xt_redist_get_num_recv_msg(redist)) &
         CALL test_abort("error in xt_redist_get_num_send_msg", &
         filename, __LINE__)
    ! test communicator of redist
    IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
         comm)) &
         CALL test_abort("error in xt_redist_get_mpi_comm", filename, __LINE__)
    CALL check_redist_extended(redist, src_data, ref_dst_data)

  END SUBROUTINE test_redist_single_array_base_dp

  SUBROUTINE check_redist_extended_dp(redist, src_data, ref_dst_data)
    TYPE(xt_redist), INTENT(inout) :: redist
    DOUBLE PRECISION, INTENT(in) :: src_data(:)
    DOUBLE PRECISION, INTENT(in) :: ref_dst_data(:)

    DOUBLE PRECISION :: dst_data(SIZE(ref_dst_data))

    TYPE(xt_redist) :: redist_copy

    ! test exchange
    CALL check_redist(redist, src_data, dst_data, ref_dst_data)
    redist_copy = xt_redist_copy(redist)
    CALL xt_redist_delete(redist)
    CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
    CALL xt_redist_delete(redist_copy)

  END SUBROUTINE check_redist_extended_dp

580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
  FUNCTION redist_exchanger_option() RESULT(config)
    TYPE(xt_config) :: config
    INTEGER :: i, j, num_cmd_args, arg_len
    INTEGER(c_int) :: exchanger_id
    INTEGER, PARAMETER :: max_opt_arg_len = 80
    CHARACTER(max_opt_arg_len) :: optarg
    CHARACTER(len=1, kind=c_char) :: optarg_c(max_opt_arg_len+1)
    INTERFACE
      FUNCTION exchanger_id_by_name(name) RESULT(exchanger_id) &
           BIND(c, name='exchanger_id_by_name')
        IMPORT :: c_char, c_int
        CHARACTER(len=1, kind=c_char), INTENT(in) :: name(*)
        INTEGER(c_int) :: exchanger_id
      END FUNCTION exchanger_id_by_name
    END INTERFACE
    config = xt_config_new()
    num_cmd_args = COMMAND_ARGUMENT_COUNT()
    i = 1
    DO WHILE (i < num_cmd_args)
      CALL GET_COMMAND_ARGUMENT(i, optarg, arg_len)
      IF (optarg(1:2) == '-m' .AND. i < num_cmd_args .AND. arg_len == 2) THEN
        CALL GET_COMMAND_ARGUMENT(i + 1, optarg, arg_len)
        IF (arg_len > max_opt_arg_len) &
             CALL test_abort('incorrect argument to command-line option -s', &
             filename, __LINE__)
        DO j = 1, arg_len
          optarg_c(j) = optarg(j:j)
        END DO
        optarg_c(arg_len+1) = c_null_char
        exchanger_id = exchanger_id_by_name(optarg_c)
        IF (exchanger_id == -1_c_int) THEN
          WRITE (0, *) 'arg to -m: ', optarg(1:arg_len)
          CALL test_abort('incorrect argument to command-line option -m', &
               filename, __LINE__)
        END IF
        CALL xt_config_set_exchange_method(config, INT(exchanger_id))
        i = i + 2
      ELSE
        WRITE (0, *) 'unexpected command-line argument parsing error: ', &
             optarg(1:arg_len)
        FLUSH(0)
        CALL test_abort('unexpected command-line argument', &
             filename, __LINE__)
      END IF
    END DO
  END FUNCTION redist_exchanger_option

627
END MODULE test_redist_common
Thomas Jahns's avatar
Thomas Jahns committed
628 629 630 631 632 633 634 635 636
!
! Local Variables:
! f90-continuation-indent: 5
! coding: utf-8
! indent-tabs-mode: nil
! show-trailing-whitespace: t
! require-trailing-newline: t
! End:
!