46 PROGRAM test_redist_single_array_base_parallel_f
51 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort
52 USE test_redist_common,
ONLY: communicators_are_congruent, &
53 test_redist_single_array_base, redist_exchanger_option
54 USE test_idxlist_utils,
ONLY: test_err_count
57 CHARACTER(len=*),
PARAMETER :: &
58 filename =
'test_redist_single_array_base_parallel_f.f90'
59 TYPE(xt_config) :: config
63 config = redist_exchanger_option()
65 CALL test_round_robin(mpi_comm_world, config)
66 CALL test_allgather(mpi_comm_world, config)
67 CALL test_scatter(mpi_comm_world, config)
69 IF (test_err_count() /= 0) &
70 CALL test_abort(
"non-zero error count!", filename, __line__)
79 SUBROUTINE test_round_robin(comm, config)
80 INTEGER,
INTENT(in) :: comm
81 TYPE(xt_config),
INTENT(in) :: config
83 TYPE(xt_redist_msg) :: send_msgs(1), recv_msgs(1)
85 INTEGER,
PARAMETER :: num_elem = 1
86 DOUBLE PRECISION :: src_data(num_elem)
87 DOUBLE PRECISION :: ref_dst_data(num_elem)
88 INTEGER :: comm_rank, comm_size, ierror
90 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
91 IF (ierror /= mpi_success) &
92 CALL test_abort(
"MPI error!", filename, __line__)
93 CALL mpi_comm_size(comm, comm_size, ierror)
94 IF (ierror /= mpi_success) &
95 CALL test_abort(
"MPI error!", filename, __line__)
97 send_msgs(1)%rank = mod(comm_rank + 1, comm_size)
98 send_msgs(1)%datatype = mpi_double_precision
99 recv_msgs(1)%rank = mod(comm_rank + comm_size - 1, comm_size)
100 recv_msgs(1)%datatype = mpi_double_precision
102 src_data(1) = dble(comm_rank)
103 ref_dst_data(1) = dble(mod(comm_rank + comm_size - 1, comm_size))
105 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
106 ref_dst_data, comm, config)
108 END SUBROUTINE test_round_robin
110 SUBROUTINE test_allgather(comm, config)
111 INTEGER,
INTENT(in) :: comm
112 TYPE(xt_config),
INTENT(in) :: config
114 TYPE(xt_redist_msg),
ALLOCATABLE :: send_msgs(:), recv_msgs(:)
116 DOUBLE PRECISION :: src_data(1)
117 DOUBLE PRECISION,
ALLOCATABLE :: ref_dst_data(:)
119 INTEGER :: comm_rank, comm_size, i, ierror
121 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
122 IF (ierror /= mpi_success) &
123 CALL test_abort(
"MPI error!", filename, __line__)
125 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
126 IF (ierror /= mpi_success) &
127 CALL test_abort(
"MPI error!", filename, __line__)
129 ALLOCATE(send_msgs(comm_size), recv_msgs(comm_size), &
130 ref_dst_data(comm_size))
132 send_msgs(i)%rank = i - 1
133 send_msgs(i)%datatype = mpi_double_precision
134 recv_msgs(i)%rank = i - 1
135 CALL mpi_type_create_indexed_block( &
136 1, 1, (/i - 1/), mpi_double_precision, recv_msgs(i)%datatype, ierror)
137 IF (ierror /= mpi_success) &
138 CALL test_abort(
"error calling mpi_type_create_indexed_block", &
140 CALL mpi_type_commit(recv_msgs(i)%datatype, ierror)
141 IF (ierror /= mpi_success) &
142 CALL test_abort(
"error calling mpi_type_commit", filename, __line__)
145 src_data(1) = dble(comm_rank)
147 ref_dst_data(i) = dble(i-1)
150 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
151 ref_dst_data, comm, config)
154 CALL mpi_type_free(recv_msgs(i)%datatype, ierror)
155 IF (ierror /= mpi_success) &
156 CALL test_abort(
"error calling mpi_type_free", filename, __line__)
159 END SUBROUTINE test_allgather
161 SUBROUTINE test_scatter(comm, config)
162 INTEGER,
INTENT(in) :: comm
163 TYPE(xt_config),
INTENT(in) :: config
165 TYPE(xt_redist_msg),
ALLOCATABLE :: send_msgs(:)
166 TYPE(xt_redist_msg) :: recv_msgs(1)
168 DOUBLE PRECISION,
ALLOCATABLE :: src_data(:)
169 DOUBLE PRECISION :: ref_dst_data(1)
171 INTEGER :: comm_size, comm_rank, i, ierror, nsend, rank, displ(1)
173 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
174 IF (ierror /= mpi_success) &
175 CALL test_abort(
"MPI error!", filename, __line__)
176 ref_dst_data(1) = dble(comm_rank)
178 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
179 IF (ierror /= mpi_success) &
180 CALL test_abort(
"MPI error!", filename, __line__)
182 nsend = merge(comm_size, 0, comm_rank == 0)
183 ALLOCATE(send_msgs(nsend))
186 send_msgs(i)%rank = rank
188 CALL mpi_type_create_indexed_block( &
189 1, 1, displ, mpi_double_precision, send_msgs(i)%datatype, ierror)
190 IF (ierror /= mpi_success) &
191 CALL test_abort(
"error calling mpi_type_create_indexed_block", &
193 CALL mpi_type_commit(send_msgs(i)%datatype, ierror)
194 IF (ierror /= mpi_success) &
195 CALL test_abort(
"error calling mpi_type_commit", filename, __line__)
197 recv_msgs(1)%rank = 0
198 recv_msgs(1)%datatype = mpi_double_precision
200 ALLOCATE(src_data(nsend))
202 src_data(i) = dble(i-1)
205 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
206 ref_dst_data, comm, config)
209 CALL mpi_type_free(send_msgs(i)%datatype, ierror)
210 IF (ierror /= mpi_success) &
211 CALL test_abort(
"error calling mpi_type_free", filename, __line__)
214 END SUBROUTINE test_scatter
216 END PROGRAM test_redist_single_array_base_parallel_f
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)