46 PROGRAM test_redist_single_array_base_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
56 CHARACTER(len=*),
PARAMETER :: &
57 filename =
'test_redist_single_array_base_f.f90'
58 TYPE(xt_config) :: config
64 config = redist_exchanger_option()
67 CALL test_single_double(mpi_comm_world, config)
69 CALL test_reverse_doubles(mpi_comm_world, config)
71 IF (test_err_count() /= 0) &
72 CALL test_abort(
"non-zero error count!", filename, __line__)
80 SUBROUTINE test_single_double(comm, config)
81 INTEGER,
INTENT(in) :: comm
82 TYPE(xt_config),
INTENT(in) :: config
85 TYPE(xt_redist_msg) :: send_msgs(1)
86 TYPE(xt_redist_msg) :: recv_msgs(1)
88 INTEGER,
PARAMETER :: num_elem = 1
89 DOUBLE PRECISION,
PARAMETER :: src_data(num_elem) &
91 DOUBLE PRECISION,
PARAMETER :: ref_dst_data(num_elem) &
95 send_msgs(1)%datatype = mpi_double_precision
97 recv_msgs(1)%datatype = mpi_double_precision
99 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
100 ref_dst_data, comm, config)
102 END SUBROUTINE test_single_double
104 SUBROUTINE test_reverse_doubles(comm, config)
105 INTEGER,
INTENT(in) :: comm
106 TYPE(xt_config),
INTENT(in) :: config
109 TYPE(xt_redist_msg) :: send_msgs(1)
110 TYPE(xt_redist_msg) :: recv_msgs(1)
113 INTEGER,
PARAMETER :: num_elem = 10
114 INTEGER,
PARAMETER :: displ(num_elem) &
115 = (/ (i, i = num_elem - 1, 0, -1) /)
117 DOUBLE PRECISION,
PARAMETER :: src_data(num_elem) &
118 = (/ (dble(i), i = 1, num_elem) /)
119 DOUBLE PRECISION,
PARAMETER :: ref_dst_data(num_elem) &
120 = (/ (dble(i), i = num_elem, 1, -1) /)
122 DOUBLE PRECISION :: src_data(num_elem), ref_dst_data(num_elem)
127 src_data(i) = dble(i)
128 ref_dst_data(i) = dble(num_elem - i + 1)
131 send_msgs(1)%rank = 0
132 CALL mpi_type_contiguous( &
133 num_elem, mpi_double_precision, send_msgs(1)%datatype, ierror)
134 IF (ierror /= mpi_success) &
135 CALL test_abort(
"error calling mpi_type_contiguous", &
137 CALL mpi_type_commit(send_msgs(1)%datatype, ierror)
138 IF (ierror /= mpi_success) &
139 CALL test_abort(
"error calling mpi_type_commit", &
141 recv_msgs(1)%rank = 0
142 CALL mpi_type_create_indexed_block(num_elem, 1, displ, &
143 mpi_double_precision, recv_msgs(1)%datatype, ierror)
144 IF (ierror /= mpi_success) &
145 CALL test_abort(
"error calling mpi_type_create_indexed_block", &
147 CALL mpi_type_commit(recv_msgs(1)%datatype, ierror)
148 IF (ierror /= mpi_success) &
149 CALL test_abort(
"error calling mpi_type_commit", &
152 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
153 ref_dst_data, comm, config)
155 CALL mpi_type_free(recv_msgs(1)%datatype, ierror)
156 IF (ierror /= mpi_success) &
157 CALL test_abort(
"error calling mpi_type_free", filename, __line__)
158 CALL mpi_type_free(send_msgs(1)%datatype, ierror)
159 IF (ierror /= mpi_success) &
160 CALL test_abort(
"error calling mpi_type_free", filename, __line__)
162 END SUBROUTINE test_reverse_doubles
164 END PROGRAM test_redist_single_array_base_f
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)