Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_single_array_base_f.f90
1
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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
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#include "fc_feature_defs.inc"
47PROGRAM test_redist_single_array_base_f
48 USE mpi
49 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_redist_msg, &
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 ! init mpi
62 CALL init_mpi
63
64 CALL xt_initialize(mpi_comm_world)
65 config = redist_exchanger_option()
66
67 ! single double
68 CALL test_single_double(mpi_comm_world, config)
69 ! reverse order of some doubles
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
75 CALL xt_config_delete(config)
76 CALL xt_finalize
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! Local Variables:
168! f90-continuation-indent: 5
169! coding: utf-8
170! indent-tabs-mode: nil
171! show-trailing-whitespace: t
172! require-trailing-newline: t
173! End:
174!
void xt_config_delete(Xt_config config)
Definition xt_config.c:85
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92