Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_single_array_base_parallel_f.f90
1
12!
13! Keywords:
14! Maintainer: Jörg Behrens <behrens@dkrz.de>
15! Moritz Hanke <hanke@dkrz.de>
16! Thomas Jahns <jahns@dkrz.de>
17! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
18!
19! Redistribution and use in source and binary forms, with or without
20! modification, are permitted provided that the following conditions are
21! met:
22!
23! Redistributions of source code must retain the above copyright notice,
24! this list of conditions and the following disclaimer.
25!
26! Redistributions in binary form must reproduce the above copyright
27! notice, this list of conditions and the following disclaimer in the
28! documentation and/or other materials provided with the distribution.
29!
30! Neither the name of the DKRZ GmbH nor the names of its contributors
31! may be used to endorse or promote products derived from this software
32! without specific prior written permission.
33!
34! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
35! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
36! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
37! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
38! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
39! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
40! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
41! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
42! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
43! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
44! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
45!
46#include "fc_feature_defs.inc"
47PROGRAM test_redist_single_array_base_parallel_f
48 USE mpi
49 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_redist_msg, &
51
52 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
53 USE test_redist_common, ONLY: &
54 test_redist_single_array_base, redist_exchanger_option
55 USE test_idxlist_utils, ONLY: test_err_count
56 IMPLICIT NONE
57
58 CHARACTER(len=*), PARAMETER :: &
59 filename = 'test_redist_single_array_base_parallel_f.f90'
60 TYPE(xt_config) :: config
61
62 CALL init_mpi
63 CALL xt_initialize(mpi_comm_world)
64 config = redist_exchanger_option()
65
66 CALL test_round_robin(mpi_comm_world, config)
67 CALL test_allgather(mpi_comm_world, config)
68 CALL test_scatter(mpi_comm_world, config)
69
70 IF (test_err_count() /= 0) &
71 CALL test_abort("non-zero error count!", filename, __line__)
72
73 CALL xt_config_delete(config)
74 CALL xt_finalize
75 CALL finish_mpi
76
77
78CONTAINS
79
80 SUBROUTINE test_round_robin(comm, config)
81 INTEGER, INTENT(in) :: comm
82 TYPE(xt_config), INTENT(in) :: config
83
84 TYPE(xt_redist_msg) :: send_msgs(1), recv_msgs(1)
85
86 INTEGER, PARAMETER :: num_elem = 1
87 DOUBLE PRECISION :: src_data(num_elem)
88 DOUBLE PRECISION :: ref_dst_data(num_elem)
89 INTEGER :: comm_rank, comm_size, ierror
90
91 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
92 IF (ierror /= mpi_success) &
93 CALL test_abort("MPI error!", filename, __line__)
94 CALL mpi_comm_size(comm, comm_size, ierror)
95 IF (ierror /= mpi_success) &
96 CALL test_abort("MPI error!", filename, __line__)
97
98 send_msgs(1)%rank = mod(comm_rank + 1, comm_size)
99 send_msgs(1)%datatype = mpi_double_precision
100 recv_msgs(1)%rank = mod(comm_rank + comm_size - 1, comm_size)
101 recv_msgs(1)%datatype = mpi_double_precision
102
103 src_data(1) = dble(comm_rank)
104 ref_dst_data(1) = dble(mod(comm_rank + comm_size - 1, comm_size))
105
106 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
107 ref_dst_data, comm, config)
108
109 END SUBROUTINE test_round_robin
110
111 SUBROUTINE test_allgather(comm, config)
112 INTEGER, INTENT(in) :: comm
113 TYPE(xt_config), INTENT(in) :: config
114
115 TYPE(xt_redist_msg), ALLOCATABLE :: send_msgs(:), recv_msgs(:)
116
117 DOUBLE PRECISION :: src_data(1)
118 DOUBLE PRECISION, ALLOCATABLE :: ref_dst_data(:)
119
120 INTEGER :: comm_rank, comm_size, i, ierror
121
122 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
123 IF (ierror /= mpi_success) &
124 CALL test_abort("MPI error!", filename, __line__)
125
126 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
127 IF (ierror /= mpi_success) &
128 CALL test_abort("MPI error!", filename, __line__)
129
130 ALLOCATE(send_msgs(comm_size), recv_msgs(comm_size), &
131 ref_dst_data(comm_size))
132 DO i = 1, comm_size
133 send_msgs(i)%rank = i - 1
134 send_msgs(i)%datatype = mpi_double_precision
135 recv_msgs(i)%rank = i - 1
136 CALL mpi_type_create_indexed_block( &
137 1, 1, (/i - 1/), mpi_double_precision, recv_msgs(i)%datatype, ierror)
138 IF (ierror /= mpi_success) &
139 CALL test_abort("error calling mpi_type_create_indexed_block", &
140 filename, __line__)
141 CALL mpi_type_commit(recv_msgs(i)%datatype, ierror)
142 IF (ierror /= mpi_success) &
143 CALL test_abort("error calling mpi_type_commit", filename, __line__)
144 END DO
145
146 src_data(1) = dble(comm_rank)
147 DO i = 1, comm_size
148 ref_dst_data(i) = dble(i-1)
149 END DO
150
151 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
152 ref_dst_data, comm, config)
153
154 DO i = 1, comm_size
155 CALL mpi_type_free(recv_msgs(i)%datatype, ierror)
156 IF (ierror /= mpi_success) &
157 CALL test_abort("error calling mpi_type_free", filename, __line__)
158 END DO
159
160 END SUBROUTINE test_allgather
161
162 SUBROUTINE test_scatter(comm, config)
163 INTEGER, INTENT(in) :: comm
164 TYPE(xt_config), INTENT(in) :: config
165
166 TYPE(xt_redist_msg), ALLOCATABLE :: send_msgs(:)
167 TYPE(xt_redist_msg) :: recv_msgs(1)
168
169 DOUBLE PRECISION, ALLOCATABLE :: src_data(:)
170 DOUBLE PRECISION :: ref_dst_data(1)
171
172 INTEGER :: comm_size, comm_rank, i, ierror, nsend, rank, displ(1)
173
174 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
175 IF (ierror /= mpi_success) &
176 CALL test_abort("MPI error!", filename, __line__)
177 ref_dst_data(1) = dble(comm_rank)
178
179 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
180 IF (ierror /= mpi_success) &
181 CALL test_abort("MPI error!", filename, __line__)
182
183 nsend = merge(comm_size, 0, comm_rank == 0)
184 ALLOCATE(send_msgs(nsend))
185 DO i = 1, nsend
186 rank = i - 1
187 send_msgs(i)%rank = rank
188 displ(1) = rank
189 CALL mpi_type_create_indexed_block( &
190 1, 1, displ, mpi_double_precision, send_msgs(i)%datatype, ierror)
191 IF (ierror /= mpi_success) &
192 CALL test_abort("error calling mpi_type_create_indexed_block", &
193 filename, __line__)
194 CALL mpi_type_commit(send_msgs(i)%datatype, ierror)
195 IF (ierror /= mpi_success) &
196 CALL test_abort("error calling mpi_type_commit", filename, __line__)
197 END DO
198 recv_msgs(1)%rank = 0
199 recv_msgs(1)%datatype = mpi_double_precision
200
201 ALLOCATE(src_data(nsend))
202 DO i = 1, nsend
203 src_data(i) = dble(i-1)
204 END DO
205
206 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
207 ref_dst_data, comm, config)
208
209 DO i = 1, nsend
210 CALL mpi_type_free(send_msgs(i)%datatype, ierror)
211 IF (ierror /= mpi_success) &
212 CALL test_abort("error calling mpi_type_free", filename, __line__)
213 END DO
214
215 END SUBROUTINE test_scatter
216
217END PROGRAM test_redist_single_array_base_parallel_f
218!
219! Local Variables:
220! f90-continuation-indent: 5
221! coding: utf-8
222! indent-tabs-mode: nil
223! show-trailing-whitespace: t
224! require-trailing-newline: t
225! End:
226!
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