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_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 CHARACTER(len=*), PARAMETER :: &
58 filename = 'test_redist_single_array_base_f.f90'
59 TYPE(xt_config) :: config
60
61
62 CALL init_mpi
63
65 config = redist_exchanger_option()
66
67
68 CALL test_single_double(mpi_comm_world, config)
69
70 CALL test_reverse_doubles(mpi_comm_world, config)
71
72 IF (test_err_count() /= 0) &
73 CALL test_abort("non-zero error count!", filename, __line__)
74
77 CALL finish_mpi
78
79CONTAINS
80
81 SUBROUTINE test_single_double(comm, config)
82 INTEGER, INTENT(in) :: comm
83 TYPE(xt_config), INTENT(in) :: config
84
85
86 TYPE(xt_redist_msg) :: send_msgs(1)
87 TYPE(xt_redist_msg) :: recv_msgs(1)
88
89 INTEGER, PARAMETER :: num_elem = 1
90 DOUBLE PRECISION, PARAMETER :: src_data(num_elem) &
91 = (/ 0.0d0 /)
92 DOUBLE PRECISION, PARAMETER :: ref_dst_data(num_elem) &
93 = (/ 0.0d0 /)
94
95 send_msgs(1)%rank = 0
96 send_msgs(1)%datatype = mpi_double_precision
97 recv_msgs(1)%rank = 0
98 recv_msgs(1)%datatype = mpi_double_precision
99
100 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
101 ref_dst_data, comm, config)
102
103 END SUBROUTINE test_single_double
104
105 SUBROUTINE test_reverse_doubles(comm, config)
106 INTEGER, INTENT(in) :: comm
107 TYPE(xt_config), INTENT(in) :: config
108
109
110 TYPE(xt_redist_msg) :: send_msgs(1)
111 TYPE(xt_redist_msg) :: recv_msgs(1)
112
113 INTEGER :: i, ierror
114 INTEGER, PARAMETER :: num_elem = 10
115 INTEGER, PARAMETER :: displ(num_elem) &
116 = (/ (i, i = num_elem - 1, 0, -1) /)
117#ifndef __PGI
118 DOUBLE PRECISION, PARAMETER :: src_data(num_elem) &
119 = (/ (dble(i), i = 1, num_elem) /)
120 DOUBLE PRECISION, PARAMETER :: ref_dst_data(num_elem) &
121 = (/ (dble(i), i = num_elem, 1, -1) /)
122#else
123 DOUBLE PRECISION :: src_data(num_elem), ref_dst_data(num_elem)
124#endif
125
126#ifdef __PGI
127 DO i = 1, num_elem
128 src_data(i) = dble(i)
129 ref_dst_data(i) = dble(num_elem - i + 1)
130 END DO
131#endif
132 send_msgs(1)%rank = 0
133 CALL mpi_type_contiguous( &
134 num_elem, mpi_double_precision, send_msgs(1)%datatype, ierror)
135 IF (ierror /= mpi_success) &
136 CALL test_abort("error calling mpi_type_contiguous", &
137 filename, __line__)
138 CALL mpi_type_commit(send_msgs(1)%datatype, ierror)
139 IF (ierror /= mpi_success) &
140 CALL test_abort("error calling mpi_type_commit", &
141 filename, __line__)
142 recv_msgs(1)%rank = 0
143 CALL mpi_type_create_indexed_block(num_elem, 1, displ, &
144 mpi_double_precision, recv_msgs(1)%datatype, ierror)
145 IF (ierror /= mpi_success) &
146 CALL test_abort("error calling mpi_type_create_indexed_block", &
147 filename, __line__)
148 CALL mpi_type_commit(recv_msgs(1)%datatype, ierror)
149 IF (ierror /= mpi_success) &
150 CALL test_abort("error calling mpi_type_commit", &
151 filename, __line__)
152
153 CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
154 ref_dst_data, comm, config)
155
156 CALL mpi_type_free(recv_msgs(1)%datatype, ierror)
157 IF (ierror /= mpi_success) &
158 CALL test_abort("error calling mpi_type_free", filename, __line__)
159 CALL mpi_type_free(send_msgs(1)%datatype, ierror)
160 IF (ierror /= mpi_success) &
161 CALL test_abort("error calling mpi_type_free", filename, __line__)
162
163 END SUBROUTINE test_reverse_doubles
164
165END PROGRAM test_redist_single_array_base_f
166
167
168
169
170
171
172
173
174
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)