Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
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#include "fc_feature_defs.inc"
49PROGRAM test_redist_collection_static
50 USE mpi
51 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
52 USE test_idxlist_utils, ONLY: test_err_count
53 USE yaxt, ONLY: xt_initialize, xt_finalize, &
57 USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist, &
58 redist_exchanger_option
59 IMPLICIT NONE
60 TYPE(xt_config) :: config
61 CHARACTER(len=*), PARAMETER :: &
62 filename = 'test_redist_collection_static_f.f90'
63 CALL init_mpi
64 CALL xt_initialize(mpi_comm_world)
65 config = redist_exchanger_option()
66
67 CALL simple_test(mpi_comm_world, config)
68 CALL test_repeated_redist(mpi_comm_world, config)
69
70 IF (test_err_count() /= 0) &
71 CALL test_abort("non-zero error count!", filename, __line__)
72 CALL xt_config_delete(config)
73 CALL xt_finalize
74 CALL finish_mpi
75CONTAINS
76 SUBROUTINE simple_test(comm, config)
77 ! general test with one redist
78 INTEGER, INTENT(in) :: comm
79 TYPE(xt_config), INTENT(in) :: config
80 ! set up data
81 TYPE(xt_xmap) :: xmap
82 TYPE(xt_redist) :: redist, redist_coll
83 INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
84 DOUBLE PRECISION, PARAMETER :: &
85 src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /), &
86 ref_dst_data(dst_slice_len) = (/ 1.0d0, 3.0d0, 5.0d0 /)
87 DOUBLE PRECISION :: dst_data(dst_slice_len)
88 INTEGER(mpi_address_kind), PARAMETER :: &
89 displacements(1) = 0_mpi_address_kind
90
91 xmap = build_odd_selection_xmap(src_slice_len, comm)
92
93 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
94
95 CALL xt_xmap_delete(xmap)
96
97 ! generate redist_collection
98 redist_coll = xt_redist_collection_static_new((/ redist /), 1, &
99 displacements, displacements, comm, config)
100
101 CALL xt_redist_delete(redist)
102
103 ! test exchange
104 CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
105
106 ! clean up
107 CALL xt_redist_delete(redist_coll)
108 END SUBROUTINE simple_test
109
110 SUBROUTINE test_repeated_redist_ds1(redist_coll)
111 TYPE(xt_redist), INTENT(in) :: redist_coll
112 INTEGER :: i, j
113 DOUBLE PRECISION, PARAMETER :: src_data(5, 3) &
114 = reshape((/ (dble(i), i = 1, 15)/), (/ 5, 3 /)), &
115 ref_dst_data(3, 3) &
116 = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
117 DOUBLE PRECISION :: dst_data(3, 3)
118
119 CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
120 END SUBROUTINE test_repeated_redist_ds1
121
122 SUBROUTINE test_repeated_redist_ds2(redist_coll)
123 TYPE(xt_redist), INTENT(in) :: redist_coll
124 INTEGER :: i, j
125 DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
126 (dble(i), i = 20, 34)/), (/ 5, 3 /)), &
127 ref_dst_data(3, 3) &
128 = reshape((/ ((dble(i + j), i = 1,5,2), j = 19,33,5) /), (/ 3, 3 /))
129 DOUBLE PRECISION, SAVE :: dst_data(3, 3)
130
131 CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
132 END SUBROUTINE test_repeated_redist_ds2
133
134 SUBROUTINE test_repeated_redist(comm, config)
135 ! test with one redist used three times (with two different input data
136 ! displacements -> test of cache) (with default cache size)
137 INTEGER, INTENT(in) :: comm
138 TYPE(xt_config), INTENT(in) :: config
139 ! set up data
140 INTEGER, PARAMETER :: num_slice = 3
141 INTEGER, PARAMETER :: src_slice_len = 5
142 TYPE(xt_xmap) :: xmap
143 TYPE(xt_redist) :: redist, redists(num_slice), redist_coll
144 INTEGER(mpi_address_kind) :: src_displacements(num_slice), &
145 dst_displacements(num_slice), src_base, dst_base, temp
146 DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
147 INTEGER :: i, ierror
148
149 xmap = build_odd_selection_xmap(src_slice_len, comm)
150
151 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
152
153 CALL xt_xmap_delete(xmap)
154
155 ! generate redist_collection
156 redists = redist
157 src_displacements(1) = 0_mpi_address_kind
158 dst_displacements(1) = 0_mpi_address_kind
159 CALL mpi_get_address(src_template(1, 1), src_base, ierror)
160 CALL mpi_get_address(dst_template(1, 1), dst_base, ierror)
161 DO i = 2, num_slice
162 CALL mpi_get_address(src_template(1, i), temp, ierror)
163 src_displacements(i) = temp - src_base
164 CALL mpi_get_address(dst_template(1, i), temp, ierror)
165 dst_displacements(i) = temp - dst_base
166 END DO
167
168 redist_coll = xt_redist_collection_static_new(redists, num_slice, &
169 src_displacements, dst_displacements, comm, config)
170 CALL xt_redist_delete(redist)
171
172 ! test exchange
173 CALL test_repeated_redist_ds1(redist_coll)
174 ! test exchange with changed displacements
175 CALL test_repeated_redist_ds2(redist_coll)
176 ! test exchange with original displacements
177 CALL test_repeated_redist_ds1(redist_coll)
178 ! clean up
179 CALL xt_redist_delete(redist_coll)
180 END SUBROUTINE test_repeated_redist
181
182END PROGRAM test_redist_collection_static
183!
184! Local Variables:
185! f90-continuation-indent: 5
186! coding: utf-8
187! indent-tabs-mode: nil
188! show-trailing-whitespace: t
189! require-trailing-newline: t
190! End:
191!
void xt_config_delete(Xt_config config)
Definition xt_config.c:85
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
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:86