Yet Another eXchange Tool  0.9.0
test_redist_single_array_base_parallel_f.f90
1 !
2 ! @file test_redist_single_array_base_parallel_f.f90
3 !
4 ! @copyright Copyright (C) 2017 Jörg Behrens <behrens@dkrz.de>
5 ! Moritz Hanke <hanke@dkrz.de>
6 ! Thomas Jahns <jahns@dkrz.de>
7 !
8 ! @author Jörg Behrens <behrens@dkrz.de>
9 ! Moritz Hanke <hanke@dkrz.de>
10 ! Thomas Jahns <jahns@dkrz.de>
11 !
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://doc.redmine.dkrz.de/yaxt/html/
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 PROGRAM test_redist_single_array_base_parallel_f
47  USE mpi
48  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_redist_msg, &
49  xt_config, xt_config_delete
50 
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
55  IMPLICIT NONE
56 
57  CHARACTER(len=*), PARAMETER :: &
58  filename = 'test_redist_single_array_base_parallel_f.f90'
59  TYPE(xt_config) :: config
60 
61  CALL init_mpi
62  CALL xt_initialize(mpi_comm_world)
63  config = redist_exchanger_option()
64 
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)
68 
69  IF (test_err_count() /= 0) &
70  CALL test_abort("non-zero error count!", filename, __line__)
71 
72  CALL xt_config_delete(config)
73  CALL xt_finalize
74  CALL finish_mpi
75 
76 
77 CONTAINS
78 
79  SUBROUTINE test_round_robin(comm, config)
80  INTEGER, INTENT(in) :: comm
81  TYPE(xt_config), INTENT(in) :: config
82 
83  TYPE(xt_redist_msg) :: send_msgs(1), recv_msgs(1)
84 
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
89 
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__)
96 
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
101 
102  src_data(1) = dble(comm_rank)
103  ref_dst_data(1) = dble(mod(comm_rank + comm_size - 1, comm_size))
104 
105  CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
106  ref_dst_data, comm, config)
107 
108  END SUBROUTINE test_round_robin
109 
110  SUBROUTINE test_allgather(comm, config)
111  INTEGER, INTENT(in) :: comm
112  TYPE(xt_config), INTENT(in) :: config
113 
114  TYPE(xt_redist_msg), ALLOCATABLE :: send_msgs(:), recv_msgs(:)
115 
116  DOUBLE PRECISION :: src_data(1)
117  DOUBLE PRECISION, ALLOCATABLE :: ref_dst_data(:)
118 
119  INTEGER :: comm_rank, comm_size, i, ierror
120 
121  CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
122  IF (ierror /= mpi_success) &
123  CALL test_abort("MPI error!", filename, __line__)
124 
125  CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
126  IF (ierror /= mpi_success) &
127  CALL test_abort("MPI error!", filename, __line__)
128 
129  ALLOCATE(send_msgs(comm_size), recv_msgs(comm_size), &
130  ref_dst_data(comm_size))
131  DO i = 1, 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", &
139  filename, __line__)
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__)
143  END DO
144 
145  src_data(1) = dble(comm_rank)
146  DO i = 1, comm_size
147  ref_dst_data(i) = dble(i-1)
148  END DO
149 
150  CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
151  ref_dst_data, comm, config)
152 
153  DO i = 1, comm_size
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__)
157  END DO
158 
159  END SUBROUTINE test_allgather
160 
161  SUBROUTINE test_scatter(comm, config)
162  INTEGER, INTENT(in) :: comm
163  TYPE(xt_config), INTENT(in) :: config
164 
165  TYPE(xt_redist_msg), ALLOCATABLE :: send_msgs(:)
166  TYPE(xt_redist_msg) :: recv_msgs(1)
167 
168  DOUBLE PRECISION, ALLOCATABLE :: src_data(:)
169  DOUBLE PRECISION :: ref_dst_data(1)
170 
171  INTEGER :: comm_size, comm_rank, i, ierror, nsend, rank, displ(1)
172 
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)
177 
178  CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
179  IF (ierror /= mpi_success) &
180  CALL test_abort("MPI error!", filename, __line__)
181 
182  nsend = merge(comm_size, 0, comm_rank == 0)
183  ALLOCATE(send_msgs(nsend))
184  DO i = 1, nsend
185  rank = i - 1
186  send_msgs(i)%rank = rank
187  displ(1) = 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", &
192  filename, __line__)
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__)
196  END DO
197  recv_msgs(1)%rank = 0
198  recv_msgs(1)%datatype = mpi_double_precision
199 
200  ALLOCATE(src_data(nsend))
201  DO i = 1, nsend
202  src_data(i) = dble(i-1)
203  END DO
204 
205  CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
206  ref_dst_data, comm, config)
207 
208  DO i = 1, nsend
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__)
212  END DO
213 
214  END SUBROUTINE test_scatter
215 
216 END PROGRAM test_redist_single_array_base_parallel_f
217 !
218 ! Local Variables:
219 ! f90-continuation-indent: 5
220 ! coding: utf-8
221 ! indent-tabs-mode: nil
222 ! show-trailing-whitespace: t
223 ! require-trailing-newline: t
224 ! End:
225 !
Definition: yaxt.f90:49
void xt_config_delete(Xt_config config)
Definition: xt_config.c:76
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89