Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_idxlist_collection_f.f90
1!>
2!! @file test_idxlist_collection_f.f90
3!!
4!! @copyright Copyright (C) 2016 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!
14! Keywords:
15! Maintainer: Jörg Behrens <behrens@dkrz.de>
16! Moritz Hanke <hanke@dkrz.de>
17! Thomas Jahns <jahns@dkrz.de>
18! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
19!
20! Redistribution and use in source and binary forms, with or without
21! modification, are permitted provided that the following conditions are
22! met:
23!
24! Redistributions of source code must retain the above copyright notice,
25! this list of conditions and the following disclaimer.
26!
27! Redistributions in binary form must reproduce the above copyright
28! notice, this list of conditions and the following disclaimer in the
29! documentation and/or other materials provided with the distribution.
30!
31! Neither the name of the DKRZ GmbH nor the names of its contributors
32! may be used to endorse or promote products derived from this software
33! without specific prior written permission.
34!
35! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
36! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
37! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
38! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
39! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
40! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
41! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
42! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
43! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
44! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
45! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
46!
47#include "fc_feature_defs.inc"
48PROGRAM test_idxlist_collection_f
49 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
50 USE mpi
51 USE test_idxlist_utils, ONLY: check_idxlist, test_err_count, &
52 idxlist_pack_unpack_copy, check_idxlist_copy
53 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
58 IMPLICIT NONE
59 CHARACTER(len=*), PARAMETER :: filename = 'test_idxlist_collection_f.f90'
60 CALL init_mpi
61 CALL xt_initialize(mpi_comm_world)
62
63 CALL test_idxlist_collection_pack_unpack
64 CALL test_idxlist_collection_copy
65 CALL test_idxlist_collection_intersection
66 CALL test_idxlist_collection_heterogeneous
67 CALL test_bounding_box1
68 CALL test_bounding_box2
69
70 CALL xt_finalize
71 IF (test_err_count() /= 0) &
72 CALL test_abort("non-zero error count!", filename, __line__)
73 CALL finish_mpi
74
75CONTAINS
76 SUBROUTINE test_idxlist_collection_pack_unpack
77 INTEGER, PARAMETER :: num_indices = 7, num_vec = 2
78 INTEGER(xt_int_kind) :: i, j
79 INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_vec) = &
80 reshape((/ ((int(i, xt_int_kind), i = 1, num_indices), &
81 & j = 1, num_vec) /), &
82 & shape = (/ num_indices, num_vec /))
83 TYPE(xt_idxlist) :: idxlists(num_vec), collectionlist, collectionlist_copy
84 TYPE(xt_stripe), PARAMETER :: ref_stripes(num_vec) = xt_stripe(1, 1, 7)
85 INTEGER :: k
86 DO k = 1, num_vec
87 idxlists(k) = xt_idxvec_new(index_list(:, k), num_indices)
88 END DO
89 collectionlist = xt_idxlist_collection_new(idxlists)
90 CALL xt_idxlist_delete(idxlists)
91 CALL check_idxlist(collectionlist, &
92 reshape(index_list, (/ SIZE(index_list) /)))
93 collectionlist_copy = idxlist_pack_unpack_copy(collectionlist)
94 CALL check_idxlist_copy(collectionlist, collectionlist_copy, &
95 reshape(index_list, (/ SIZE(index_list) /)), ref_stripes)
96 CALL xt_idxlist_delete(collectionlist_copy)
97 CALL xt_idxlist_delete(collectionlist)
98 END SUBROUTINE test_idxlist_collection_pack_unpack
99
100 SUBROUTINE test_idxlist_collection_copy
101 INTEGER, PARAMETER :: num_indices = 7, num_vec = 2
102 INTEGER(xt_int_kind) :: i, j
103 INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_vec) = &
104 reshape((/ ((int(num_indices - (j * num_indices + 1 - j - i) &
105 & * (2*j - 1), xt_int_kind), &
106 & i=1, num_indices), j=1,0,-1) /), &
107 & (/ num_indices, num_vec /))
108 TYPE(xt_idxlist) :: idxlists(num_vec), collectionlist, collectionlist_copy
109 TYPE(xt_stripe), PARAMETER :: ref_stripes(num_vec) &
110 = (/ xt_stripe(1, 1, 7), xt_stripe(7, -1, 7) /)
111 INTEGER :: k
112 DO k = 1, num_vec
113 idxlists(k) = xt_idxvec_new(index_list(:, k), num_indices)
114 END DO
115 collectionlist = xt_idxlist_collection_new(idxlists)
116 CALL xt_idxlist_delete(idxlists)
117 CALL check_idxlist(collectionlist, &
118 reshape(index_list, (/ SIZE(index_list) /)))
119 collectionlist_copy = idxlist_pack_unpack_copy(collectionlist)
120 CALL check_idxlist_copy(collectionlist, collectionlist_copy, &
121 reshape(index_list, (/ SIZE(index_list) /)), ref_stripes)
122 CALL xt_idxlist_delete(collectionlist_copy)
123 CALL xt_idxlist_delete(collectionlist)
124 END SUBROUTINE test_idxlist_collection_copy
125
126 SUBROUTINE test_idxlist_collection_intersection
127 INTEGER, PARAMETER :: num_indices = 7, num_lists = 3
128 INTEGER, PARAMETER :: xi = xt_int_kind
129 INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_lists) &
130 = reshape((/ 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, &
131 & 7_xi, 6_xi, 5_xi, 4_xi, 3_xi, 2_xi, 1_xi, &
132 & 2_xi, 6_xi, 1_xi, 4_xi, 7_xi, 3_xi, 0_xi /), &
133 & (/ num_indices, num_lists /)), &
134 sorted_index_list(SIZE(index_list)) &
135 = (/ 0_xi, 1_xi, 1_xi, 1_xi, 2_xi, 2_xi, 2_xi, &
136 & 3_xi, 3_xi, 3_xi, 4_xi, 4_xi, 4_xi, 5_xi, &
137 & 5_xi, 6_xi, 6_xi, 6_xi, 7_xi, 7_xi, 7_xi /)
138 TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist, intersection, &
139 ref_idxvec
140 INTEGER :: i
141
142 DO i = 1, 3
143 idxlists(i) = xt_idxvec_new(index_list(:, i), num_indices)
144 END DO
145 collectionlist = xt_idxlist_collection_new(idxlists)
146 DO i = 1, 3
147 CALL xt_idxlist_delete(idxlists(i))
148 END DO
149 CALL check_idxlist(collectionlist, &
150 reshape(index_list, (/ SIZE(index_list) /)))
151 ref_idxvec = xt_idxvec_new(reshape(index_list, (/ SIZE(index_list) /)), &
152 SIZE(index_list))
153 intersection = xt_idxlist_get_intersection(ref_idxvec, collectionlist)
154 CALL check_idxlist(intersection, sorted_index_list)
155 CALL xt_idxlist_delete(intersection)
156 intersection = xt_idxlist_get_intersection(collectionlist, ref_idxvec)
157 CALL check_idxlist(intersection, sorted_index_list)
158 CALL xt_idxlist_delete(intersection)
159 CALL xt_idxlist_delete(ref_idxvec)
160 CALL xt_idxlist_delete(collectionlist)
161
162 END SUBROUTINE test_idxlist_collection_intersection
163
164 SUBROUTINE test_idxlist_collection_heterogeneous
165 INTEGER, PARAMETER :: num_indices = 6, num_lists = 3
166 INTEGER, PARAMETER :: xi = xt_int_kind
167 INTEGER(xt_int_kind), PARAMETER :: &
168 index_list(num_indices) = (/ 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, 11_xi /)
169 TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(0, 2, 5), &
170 xt_stripe(1, 2, 5) /)
171 INTEGER(xt_int_kind), PARAMETER :: local_start(2) = 2
172 INTEGER(xt_int_kind), PARAMETER :: global_size(2) = (/ 10_xi, 10_xi /)
173 INTEGER, PARAMETER :: local_size(2) = 5
174 INTEGER, PARAMETER :: ref_size = num_indices + stripes(1)%nstrides &
175 + stripes(2)%nstrides + local_size(1) * local_size(2)
176 INTEGER(xt_int_kind), PARAMETER :: ref_index_list(ref_size) &
177 = (/ 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, 11_xi, &
178 & 0_xi, 2_xi, 4_xi, 6_xi, 8_xi, 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, &
179 & 22_xi, 23_xi, 24_xi, 25_xi, 26_xi, &
180 & 32_xi, 33_xi, 34_xi, 35_xi, 36_xi, &
181 & 42_xi, 43_xi, 44_xi, 45_xi, 46_xi, &
182 & 52_xi, 53_xi, 54_xi, 55_xi, 56_xi, &
183 & 62_xi, 63_xi, 64_xi, 65_xi, 66_xi /)
184 TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
185
186 idxlists(1) = xt_idxvec_new(index_list, SIZE(index_list))
187 idxlists(2) = xt_idxstripes_new(stripes, SIZE(stripes))
188 idxlists(3) = xt_idxsection_new(0_xt_int_kind, global_size, local_size, &
189 local_start)
190
191 ! generate a collection index list
192 collectionlist = xt_idxlist_collection_new(idxlists)
193
194 CALL xt_idxlist_delete(idxlists)
195
196 ! test generated collection list
197 CALL check_idxlist(collectionlist, ref_index_list)
198
199 CALL xt_idxlist_delete(collectionlist)
200
201 END SUBROUTINE test_idxlist_collection_heterogeneous
202
203 SUBROUTINE test_bounding_box1
204 INTEGER, PARAMETER :: ndim=3, num_lists = 2
205 INTEGER(xt_int_kind), PARAMETER :: global_size_bb(ndim) = 4, &
206 global_start_index = 0
207 TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
208 TYPE(xt_bounds) :: bounds(ndim)
209 INTEGER :: i
210
211 DO i = 1, num_lists
212 idxlists(i) = xt_idxempty_new()
213 END DO
214 collectionlist = xt_idxlist_collection_new(idxlists)
215 CALL xt_idxlist_delete(idxlists)
216 bounds = xt_idxlist_get_bounding_box(collectionlist, global_size_bb, &
217 global_start_index)
218 IF (any(bounds%size /= 0)) &
219 CALL test_abort("ERROR: non-zero bounding box size", &
220 filename, __line__)
221 CALL xt_idxlist_delete(collectionlist)
222 END SUBROUTINE test_bounding_box1
223
224 SUBROUTINE test_bounding_box2
225 INTEGER, PARAMETER :: ndim = 3, num_lists = 2, num_indices = 3
226 INTEGER, PARAMETER :: xi = xt_int_kind
227 INTEGER(xt_int_kind), PARAMETER :: indices(num_indices, num_lists) &
228 = reshape( (/ 45_xi, 35_xi, 32_xi, 32_xi, 48_xi, 33_xi /), &
229 & (/ num_indices, num_lists /)), &
230 global_size(ndim) = (/ 5_xi, 4_xi, 3_xi /), &
231 global_start_index = 1
232 TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
233 TYPE(xt_bounds) :: bounds(ndim)
234 TYPE(xt_bounds), PARAMETER :: bounds_ref(ndim) = (/ xt_bounds(2, 2), &
235 xt_bounds(2, 2), xt_bounds(1, 2) /)
236 INTEGER :: i
237
238 DO i = 1, num_lists
239 idxlists(i) = xt_idxvec_new(indices(:, i), SIZE(indices, 1))
240 END DO
241 collectionlist = xt_idxlist_collection_new(idxlists)
242 CALL xt_idxlist_delete(idxlists)
243
244 bounds = xt_idxlist_get_bounding_box(collectionlist, global_size, &
245 global_start_index)
246 CALL xt_idxlist_delete(collectionlist)
247 IF (any(bounds /= bounds_ref)) &
248 CALL test_abort("ERROR: unexpected boundaries", filename, __line__)
249 END SUBROUTINE test_bounding_box2
250
251END PROGRAM test_idxlist_collection_f
252!
253! Local Variables:
254! f90-continuation-indent: 5
255! coding: utf-8
256! indent-tabs-mode: nil
257! show-trailing-whitespace: t
258! require-trailing-newline: t
259! End:
260!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
Xt_idxlist xt_idxempty_new(void)
void xt_idxlist_get_bounding_box(Xt_idxlist idxlist, unsigned ndim, const Xt_int global_size[ndim], Xt_int global_start_index, struct Xt_bounds bounds[ndim])
Definition xt_idxlist.c:379
Xt_idxlist xt_idxlist_get_intersection(Xt_idxlist idxlist_src, Xt_idxlist idxlist_dst)
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
Xt_idxlist xt_idxlist_collection_new(Xt_idxlist *idxlists, int num_idxlists)
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition xt_idxvec.c:213