1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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#include "fc_feature_defs.inc"
47PROGRAM test_redist_single_array_base_parallel_f
48 USE mpi
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
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
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
220
221
222
223
224
225
226
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)