Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_collection_displace_f.f90
1!>
2!! @file test_redist_collection_displace_f.f90
3!! @brief Fortran cache displacement test of redist_collection class
4!!
5!! @copyright Copyright (C) 2016 Jörg Behrens <behrens@dkrz.de>
6!! Moritz Hanke <hanke@dkrz.de>
7!! Thomas Jahns <jahns@dkrz.de>
8!!
9!! @author Jörg Behrens <behrens@dkrz.de>
10!! Moritz Hanke <hanke@dkrz.de>
11!! Thomas Jahns <jahns@dkrz.de>
12!!
13
14!
15! Keywords:
16! Maintainer: Jörg Behrens <behrens@dkrz.de>
17! Moritz Hanke <hanke@dkrz.de>
18! Thomas Jahns <jahns@dkrz.de>
19! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
20!
21! Redistribution and use in source and binary forms, with or without
22! modification, are permitted provided that the following conditions are
23! met:
24!
25! Redistributions of source code must retain the above copyright notice,
26! this list of conditions and the following disclaimer.
27!
28! Redistributions in binary form must reproduce the above copyright
29! notice, this list of conditions and the following disclaimer in the
30! documentation and/or other materials provided with the distribution.
31!
32! Neither the name of the DKRZ GmbH nor the names of its contributors
33! may be used to endorse or promote products derived from this software
34! without specific prior written permission.
35!
36! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47!
48#include "fc_feature_defs.inc"
49MODULE redist_collection_displace
50 USE mpi
51 USE ftest_common, ONLY: test_abort, cmp_arrays
52 USE yaxt, ONLY: &
57 ! older PGI compilers do not handle generic interface correctly
58#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
59 USE xt_redist_base, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
60#endif
61 ! and when taking the slice address and the optimizer is on,
62 ! some other random failure occurs even with very recent compiler versions
63#if defined __PGI && (__PGIC__ <= 23 || __PGIC__ == 24 && __PGIC_MINOR__ <= 3)
64#undef HAVE_FC_C_LOC_OF_SLICE
65#endif
66 USE test_redist_common, ONLY: build_odd_selection_xmap, &
67 check_wait_request
68 USE iso_c_binding, ONLY: c_ptr
69#include "xt_slice_c_loc.inc"
70 IMPLICIT NONE
71 PRIVATE
72 INTEGER, PARAMETER :: cache_size = 16, cache_overrun = 2
73 INTEGER, PARAMETER :: num_slice = 3, dst_step = 2
74 INTEGER, PARAMETER :: src_slice_len = 5
75 INTEGER, PARAMETER :: dst_slice_len &
76 = (src_slice_len + dst_step - 1)/dst_step
77 CHARACTER(len=*), PARAMETER :: &
78 filename = 'test_redist_collection_displace_f.f90'
79 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
80 (/ "error on xt_redist_s_exchange", "error on xt_redist_a_exchange" /)
81 PUBLIC :: test_displacement_variations
82CONTAINS
83 ! test with one redist used three times (with different input
84 ! data displacements until the cache is full)
85 ! set up data
86 SUBROUTINE test_displacement_variations(comm, config)
87 INTEGER, INTENT(in) :: comm
88 TYPE(xt_config), INTENT(in) :: config
89 TYPE(xt_xmap) :: xmap
90 TYPE(xt_redist) :: redist, redists(num_slice), redist_coll, &
91 redist_coll_copy
92
93 xmap = build_odd_selection_xmap(src_slice_len, comm)
94 redist = xt_redist_p2p_new(xmap, mpi_double_precision, config)
95
96 CALL xt_xmap_delete(xmap)
97
98 ! generate redist_collection
99 redists = redist
100
101 redist_coll = xt_redist_collection_new(redists, num_slice, &
102 cache_size, comm, config)
103
104 CALL xt_redist_delete(redist)
105
106 CALL run_displacement_check(redist_coll)
107 redist_coll_copy = xt_redist_copy(redist_coll)
108 CALL run_displacement_check(redist_coll_copy)
109
110 ! clean up
111 CALL xt_redist_delete(redist_coll)
112 CALL xt_redist_delete(redist_coll_copy)
113 END SUBROUTINE test_displacement_variations
114
115#ifndef HAVE_FC_PTR_BOUND_REMAP
116 SUBROUTINE ptr_bind(p, ub, a)
117 DOUBLE PRECISION, POINTER :: p(:,:)
118 INTEGER, INTENT(in) :: ub(2)
119 DOUBLE PRECISION, TARGET :: a(ub(1), ub(2))
120 p => a
121 END SUBROUTINE ptr_bind
122#endif
123
124 SUBROUTINE run_displacement_check(redist_coll)
125 TYPE(xt_redist), INTENT(in) :: redist_coll
126 INTEGER :: i, j, k
127 DOUBLE PRECISION, TARGET :: &
128 src(src_slice_len * (num_slice+1) + cache_size + cache_overrun), &
129 dst(dst_slice_len * (num_slice+1) + cache_size + cache_overrun)
130 DOUBLE PRECISION, POINTER :: src_data(:, :), dst_data(:, :)
131 DOUBLE PRECISION, POINTER :: src_data_(:), dst_data_(:)
132 TYPE(c_ptr) :: src_data_p(num_slice), dst_data_p(num_slice)
133 DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_slice_len, num_slice) = &
134 reshape((/ ((dble(i + j * src_slice_len), &
135 & i = 1, src_slice_len, dst_step), &
136 & j = 0, num_slice - 1) /), &
137 & (/ dst_slice_len, num_slice /))
138 TYPE(xt_request) :: request
139 INTEGER :: iexch
140
141#ifdef HAVE_FC_PTR_BOUND_REMAP
142 src_data(1:src_slice_len, 1:num_slice) => src(1:src_slice_len*num_slice)
143#else
144 CALL ptr_bind(src_data, (/ src_slice_len, num_slice /), src)
145#endif
146 DO j = 1, num_slice
147 DO i = 1, src_slice_len
148 src_data(i, j) = dble(i + (j - 1) * src_slice_len)
149 END DO
150 END DO
151
152 src_data_ => src(src_slice_len*num_slice+1:)
153
154#ifdef HAVE_FC_PTR_BOUND_REMAP
155 dst_data(1:dst_slice_len, 1:num_slice) => dst(1:dst_slice_len*num_slice)
156#else
157 CALL ptr_bind(dst_data, (/ dst_slice_len, num_slice /), dst)
158#endif
159
160 dst_data_ => dst(dst_slice_len*num_slice+1:)
161
162 DO i = 1, num_slice - 1
163 xt_slice_c_loc(src_data(:, i), src_data_p(i))
164 xt_slice_c_loc(dst_data(:, i), dst_data_p(i))
165 END DO
166
167 ! test exchange
168 DO k = 1, cache_size + cache_overrun
169 src_data_(k:k+src_slice_len-1) = src_data(:,num_slice)
170
171
172 xt_slice_c_loc(src_data_(k:k+src_slice_len-1), src_data_p(3))
173 xt_slice_c_loc(dst_data_(k:k+dst_slice_len-1), dst_data_p(3))
174
175 DO iexch = 1, 2
176 dst = -1.0d0
177 IF (iexch == 1) THEN
178 CALL xt_redist_s_exchange(redist_coll, num_slice, src_data_p, &
179 dst_data_p)
180 ELSE
181 CALL xt_redist_a_exchange(redist_coll, num_slice, src_data_p, &
182 dst_data_p, request)
183 CALL check_wait_request(request, filename, __line__)
184 ENDIF
185 IF (cmp_arrays(ref_dst_data(:, 1:num_slice-1), &
186 & dst_data(:, 1:num_slice-1)) &
187 .OR. cmp_arrays(ref_dst_data(:,num_slice), &
188 & dst_data_(k:k+dst_slice_len-1))) &
189 CALL test_abort(err_msg(iexch), filename, __line__)
190 ENDDO
191 END DO
192 END SUBROUTINE run_displacement_check
193
194END MODULE redist_collection_displace
195!
196! Local Variables:
197! f90-continuation-indent: 5
198! coding: utf-8
199! indent-tabs-mode: nil
200! show-trailing-whitespace: t
201! require-trailing-newline: t
202! End:
203!
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
Xt_redist xt_redist_copy(Xt_redist redist)
Definition xt_redist.c:69
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[], Xt_request *request)
Xt_redist xt_redist_collection_new(Xt_redist *redists, int num_redists, int cache_size, MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86