Yet Another eXchange Tool  0.9.0
test_redist_collection_static_f.f90
1 
13 
14 !
15 ! Keywords:
16 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
17 ! Moritz Hanke <hanke@dkrz.de>
18 ! Thomas Jahns <jahns@dkrz.de>
19 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
20 !
21 ! Redistribution and use in source and binary forms, with or without
22 ! modification, are permitted provided that the following conditions are
23 ! met:
24 !
25 ! Redistributions of source code must retain the above copyright notice,
26 ! this list of conditions and the following disclaimer.
27 !
28 ! Redistributions in binary form must reproduce the above copyright
29 ! notice, this list of conditions and the following disclaimer in the
30 ! documentation and/or other materials provided with the distribution.
31 !
32 ! Neither the name of the DKRZ GmbH nor the names of its contributors
33 ! may be used to endorse or promote products derived from this software
34 ! without specific prior written permission.
35 !
36 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47 !
48 PROGRAM test_redist_collection_static
49  USE mpi
50  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
51  USE test_idxlist_utils, ONLY: test_err_count
52  USE yaxt, ONLY: xt_initialize, xt_finalize, &
53  xt_xmap, xt_xmap_delete, &
56  USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist, &
57  redist_exchanger_option
58  IMPLICIT NONE
59  TYPE(xt_config) :: config
60  CHARACTER(len=*), PARAMETER :: &
61  filename = 'test_redist_collection_static_f.f90'
62  CALL init_mpi
63  CALL xt_initialize(mpi_comm_world)
64  config = redist_exchanger_option()
65 
66  CALL simple_test(mpi_comm_world, config)
67  CALL test_repeated_redist(mpi_comm_world, config)
68 
69  IF (test_err_count() /= 0) &
70  CALL test_abort("non-zero error count!", filename, __line__)
71  CALL xt_config_delete(config)
72  CALL xt_finalize
73  CALL finish_mpi
74 CONTAINS
75  SUBROUTINE simple_test(comm, config)
76  ! general test with one redist
77  INTEGER, INTENT(in) :: comm
78  TYPE(xt_config), INTENT(in) :: config
79  ! set up data
80  TYPE(xt_xmap) :: xmap
81  TYPE(xt_redist) :: redist, redist_coll
82  INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
83  DOUBLE PRECISION, PARAMETER :: &
84  src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /), &
85  ref_dst_data(dst_slice_len) = (/ 1.0d0, 3.0d0, 5.0d0 /)
86  DOUBLE PRECISION :: dst_data(dst_slice_len)
87  INTEGER(mpi_address_kind), PARAMETER :: &
88  displacements(1) = 0_mpi_address_kind
89 
90  xmap = build_odd_selection_xmap(src_slice_len)
91 
92  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
93 
94  CALL xt_xmap_delete(xmap)
95 
96  ! generate redist_collection
97  redist_coll = xt_redist_collection_static_new((/ redist /), 1, &
98  displacements, displacements, comm, config)
99 
100  CALL xt_redist_delete(redist)
101 
102  ! test exchange
103  CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
104 
105  ! clean up
106  CALL xt_redist_delete(redist_coll)
107  END SUBROUTINE simple_test
108 
109  SUBROUTINE test_repeated_redist_ds1(redist_coll)
110  TYPE(xt_redist), INTENT(in) :: redist_coll
111  INTEGER :: i, j
112  DOUBLE PRECISION, PARAMETER :: src_data(5, 3) &
113  = reshape((/ (dble(i), i = 1, 15)/), (/ 5, 3 /)), &
114  ref_dst_data(3, 3) &
115  = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
116  DOUBLE PRECISION :: dst_data(3, 3)
117 
118  CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
119  END SUBROUTINE test_repeated_redist_ds1
120 
121  SUBROUTINE test_repeated_redist_ds2(redist_coll)
122  TYPE(xt_redist), INTENT(in) :: redist_coll
123  INTEGER :: i, j
124  DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
125  (dble(i), i = 20, 34)/), (/ 5, 3 /)), &
126  ref_dst_data(3, 3) &
127  = reshape((/ ((dble(i + j), i = 1,5,2), j = 19,33,5) /), (/ 3, 3 /))
128  DOUBLE PRECISION, SAVE :: dst_data(3, 3)
129 
130  CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
131  END SUBROUTINE test_repeated_redist_ds2
132 
133  SUBROUTINE test_repeated_redist(comm, config)
134  ! test with one redist used three times (with two different input data
135  ! displacements -> test of cache) (with default cache size)
136  INTEGER, INTENT(in) :: comm
137  TYPE(xt_config), INTENT(in) :: config
138  ! set up data
139  INTEGER, PARAMETER :: num_slice = 3
140  INTEGER, PARAMETER :: src_slice_len = 5
141  TYPE(xt_xmap) :: xmap
142  TYPE(xt_redist) :: redist, redists(num_slice), redist_coll
143  INTEGER(mpi_address_kind) :: src_displacements(num_slice), &
144  dst_displacements(num_slice), src_base, dst_base, temp
145  DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
146  INTEGER :: i, ierror
147 
148  xmap = build_odd_selection_xmap(src_slice_len)
149 
150  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
151 
152  CALL xt_xmap_delete(xmap)
153 
154  ! generate redist_collection
155  redists = redist
156  src_displacements(1) = 0_mpi_address_kind
157  dst_displacements(1) = 0_mpi_address_kind
158  CALL mpi_get_address(src_template(1, 1), src_base, ierror)
159  CALL mpi_get_address(dst_template(1, 1), dst_base, ierror)
160  DO i = 2, num_slice
161  CALL mpi_get_address(src_template(1, i), temp, ierror)
162  src_displacements(i) = temp - src_base
163  CALL mpi_get_address(dst_template(1, i), temp, ierror)
164  dst_displacements(i) = temp - dst_base
165  END DO
166 
167  redist_coll = xt_redist_collection_static_new(redists, num_slice, &
168  src_displacements, dst_displacements, comm, config)
169  CALL xt_redist_delete(redist)
170 
171  ! test exchange
172  CALL test_repeated_redist_ds1(redist_coll)
173  ! test exchange with changed displacements
174  CALL test_repeated_redist_ds2(redist_coll)
175  ! test exchange with original displacements
176  CALL test_repeated_redist_ds1(redist_coll)
177  ! clean up
178  CALL xt_redist_delete(redist_coll)
179  END SUBROUTINE test_repeated_redist
180 
181 END PROGRAM test_redist_collection_static
182 !
183 ! Local Variables:
184 ! f90-continuation-indent: 5
185 ! coding: utf-8
186 ! indent-tabs-mode: nil
187 ! show-trailing-whitespace: t
188 ! require-trailing-newline: t
189 ! End:
190 !
Definition: yaxt.f90:49
void xt_config_delete(Xt_config config)
Definition: xt_config.c:76
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
void xt_redist_delete(Xt_redist redist)
Definition: xt_redist.c:68
Xt_redist xt_redist_collection_static_new(Xt_redist *redists, int num_redists, const MPI_Aint src_displacements[num_redists], const MPI_Aint dst_displacements[num_redists], MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition: xt_xmap.c:85