Yet Another eXchange Tool  0.9.0
test_idxlist_collection_f.f90
1 
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://doc.redmine.dkrz.de/yaxt/html/
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 PROGRAM test_idxlist_collection_f
48  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
49  USE mpi
50  USE test_idxlist_utils, ONLY: check_idxlist, test_err_count, &
51  idxlist_pack_unpack_copy, check_idxlist_copy
52  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
53  xt_idxlist, xt_idxvec_new, &
56  xt_bounds, xt_idxempty_new, xt_idxlist_get_bounding_box, OPERATOR(/=)
57  IMPLICIT NONE
58  CHARACTER(len=*), PARAMETER :: filename = 'test_idxlist_collection_f.f90'
59  CALL init_mpi
60  CALL xt_initialize(mpi_comm_world)
61 
62  CALL test_idxlist_collection_pack_unpack
63  CALL test_idxlist_collection_copy
64  CALL test_idxlist_collection_intersection
65  CALL test_idxlist_collection_heterogeneous
66  CALL test_bounding_box1
67  CALL test_bounding_box2
68 
69  CALL xt_finalize
70  IF (test_err_count() /= 0) &
71  CALL test_abort("non-zero error count!", filename, __line__)
72  CALL finish_mpi
73 
74 CONTAINS
75  SUBROUTINE test_idxlist_collection_pack_unpack
76  INTEGER, PARAMETER :: num_indices = 7, num_vec = 2
77  INTEGER(xt_int_kind) :: i, j
78  INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_vec) = &
79  reshape((/ ((int(i, xt_int_kind), i = 1, num_indices), &
80  & j = 1, num_vec) /), &
81  & shape = (/ num_indices, num_vec /))
82  TYPE(xt_idxlist) :: idxlists(num_vec), collectionlist, collectionlist_copy
83  TYPE(xt_stripe), PARAMETER :: ref_stripes(num_vec) = xt_stripe(1, 1, 7)
84  INTEGER :: k
85  DO k = 1, num_vec
86  idxlists(k) = xt_idxvec_new(index_list(:, k), num_indices)
87  END DO
88  collectionlist = xt_idxlist_collection_new(idxlists)
89  CALL xt_idxlist_delete(idxlists)
90  CALL check_idxlist(collectionlist, &
91  reshape(index_list, (/ SIZE(index_list) /)))
92  collectionlist_copy = idxlist_pack_unpack_copy(collectionlist)
93  CALL check_idxlist_copy(collectionlist, collectionlist_copy, &
94  reshape(index_list, (/ SIZE(index_list) /)), ref_stripes)
95  CALL xt_idxlist_delete(collectionlist_copy)
96  CALL xt_idxlist_delete(collectionlist)
97  END SUBROUTINE test_idxlist_collection_pack_unpack
98 
99  SUBROUTINE test_idxlist_collection_copy
100  INTEGER, PARAMETER :: num_indices = 7, num_vec = 2
101  INTEGER(xt_int_kind) :: i, j
102  INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_vec) = &
103  reshape((/ ((int(num_indices - (j * num_indices + 1 - j - i) &
104  & * (2*j - 1), xt_int_kind), &
105  & i=1, num_indices), j=1,0,-1) /), &
106  & (/ num_indices, num_vec /))
107  TYPE(xt_idxlist) :: idxlists(num_vec), collectionlist, collectionlist_copy
108  TYPE(xt_stripe), PARAMETER :: ref_stripes(num_vec) &
109  = (/ xt_stripe(1, 1, 7), xt_stripe(7, -1, 7) /)
110  INTEGER :: k
111  DO k = 1, num_vec
112  idxlists(k) = xt_idxvec_new(index_list(:, k), num_indices)
113  END DO
114  collectionlist = xt_idxlist_collection_new(idxlists)
115  CALL xt_idxlist_delete(idxlists)
116  CALL check_idxlist(collectionlist, &
117  reshape(index_list, (/ SIZE(index_list) /)))
118  collectionlist_copy = idxlist_pack_unpack_copy(collectionlist)
119  CALL check_idxlist_copy(collectionlist, collectionlist_copy, &
120  reshape(index_list, (/ SIZE(index_list) /)), ref_stripes)
121  CALL xt_idxlist_delete(collectionlist_copy)
122  CALL xt_idxlist_delete(collectionlist)
123  END SUBROUTINE test_idxlist_collection_copy
124 
125  SUBROUTINE test_idxlist_collection_intersection
126  INTEGER, PARAMETER :: num_indices = 7, num_lists = 3
127  INTEGER, PARAMETER :: xi = xt_int_kind
128  INTEGER(xt_int_kind), PARAMETER :: index_list(num_indices, num_lists) &
129  = reshape((/ 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, &
130  & 7_xi, 6_xi, 5_xi, 4_xi, 3_xi, 2_xi, 1_xi, &
131  & 2_xi, 6_xi, 1_xi, 4_xi, 7_xi, 3_xi, 0_xi /), &
132  & (/ num_indices, num_lists /)), &
133  sorted_index_list(SIZE(index_list)) &
134  = (/ 0_xi, 1_xi, 1_xi, 1_xi, 2_xi, 2_xi, 2_xi, &
135  & 3_xi, 3_xi, 3_xi, 4_xi, 4_xi, 4_xi, 5_xi, &
136  & 5_xi, 6_xi, 6_xi, 6_xi, 7_xi, 7_xi, 7_xi /)
137  TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist, intersection, &
138  ref_idxvec
139  INTEGER :: i
140 
141  DO i = 1, 3
142  idxlists(i) = xt_idxvec_new(index_list(:, i), num_indices)
143  END DO
144  collectionlist = xt_idxlist_collection_new(idxlists)
145  DO i = 1, 3
146  CALL xt_idxlist_delete(idxlists(i))
147  END DO
148  CALL check_idxlist(collectionlist, &
149  reshape(index_list, (/ SIZE(index_list) /)))
150  ref_idxvec = xt_idxvec_new(reshape(index_list, (/ SIZE(index_list) /)), &
151  SIZE(index_list))
152  intersection = xt_idxlist_get_intersection(ref_idxvec, collectionlist)
153  CALL check_idxlist(intersection, sorted_index_list)
154  CALL xt_idxlist_delete(intersection)
155  intersection = xt_idxlist_get_intersection(collectionlist, ref_idxvec)
156  CALL check_idxlist(intersection, sorted_index_list)
157  CALL xt_idxlist_delete(intersection)
158  CALL xt_idxlist_delete(ref_idxvec)
159  CALL xt_idxlist_delete(collectionlist)
160 
161  END SUBROUTINE test_idxlist_collection_intersection
162 
163  SUBROUTINE test_idxlist_collection_heterogeneous
164  INTEGER, PARAMETER :: num_indices = 6, num_lists = 3
165  INTEGER, PARAMETER :: xi = xt_int_kind
166  INTEGER(xt_int_kind), PARAMETER :: &
167  index_list(num_indices) = (/ 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, 11_xi /)
168  TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(0, 2, 5), &
169  xt_stripe(1, 2, 5) /)
170  INTEGER(xt_int_kind), PARAMETER :: local_start(2) = 2
171  INTEGER(xt_int_kind), PARAMETER :: global_size(2) = (/ 10_xi, 10_xi /)
172  INTEGER, PARAMETER :: local_size(2) = 5
173  INTEGER, PARAMETER :: ref_size = num_indices + stripes(1)%nstrides &
174  + stripes(2)%nstrides + local_size(1) * local_size(2)
175  INTEGER(xt_int_kind), PARAMETER :: ref_index_list(ref_size) &
176  = (/ 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, 11_xi, &
177  & 0_xi, 2_xi, 4_xi, 6_xi, 8_xi, 1_xi, 3_xi, 5_xi, 7_xi, 9_xi, &
178  & 22_xi, 23_xi, 24_xi, 25_xi, 26_xi, &
179  & 32_xi, 33_xi, 34_xi, 35_xi, 36_xi, &
180  & 42_xi, 43_xi, 44_xi, 45_xi, 46_xi, &
181  & 52_xi, 53_xi, 54_xi, 55_xi, 56_xi, &
182  & 62_xi, 63_xi, 64_xi, 65_xi, 66_xi /)
183  TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
184 
185  idxlists(1) = xt_idxvec_new(index_list, SIZE(index_list))
186  idxlists(2) = xt_idxstripes_new(stripes, SIZE(stripes))
187  idxlists(3) = xt_idxsection_new(0_xt_int_kind, global_size, local_size, &
188  local_start)
189 
190  ! generate a collection index list
191  collectionlist = xt_idxlist_collection_new(idxlists)
192 
193  CALL xt_idxlist_delete(idxlists)
194 
195  ! test generated collection list
196  CALL check_idxlist(collectionlist, ref_index_list)
197 
198  CALL xt_idxlist_delete(collectionlist)
199 
200  END SUBROUTINE test_idxlist_collection_heterogeneous
201 
202  SUBROUTINE test_bounding_box1
203  INTEGER, PARAMETER :: ndim=3, num_lists = 2
204  INTEGER(xt_int_kind), PARAMETER :: global_size_bb(ndim) = 4, &
205  global_start_index = 0
206  TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
207  TYPE(xt_bounds) :: bounds(ndim)
208  INTEGER :: i
209 
210  DO i = 1, num_lists
211  idxlists(i) = xt_idxempty_new()
212  END DO
213  collectionlist = xt_idxlist_collection_new(idxlists)
214  CALL xt_idxlist_delete(idxlists)
215  bounds = xt_idxlist_get_bounding_box(collectionlist, global_size_bb, &
216  global_start_index)
217  IF (any(bounds%size /= 0)) &
218  CALL test_abort("ERROR: non-zero bounding box size", &
219  filename, __line__)
220  CALL xt_idxlist_delete(collectionlist)
221  END SUBROUTINE test_bounding_box1
222 
223  SUBROUTINE test_bounding_box2
224  INTEGER, PARAMETER :: ndim = 3, num_lists = 2, num_indices = 3
225  INTEGER, PARAMETER :: xi = xt_int_kind
226  INTEGER(xt_int_kind), PARAMETER :: indices(num_indices, num_lists) &
227  = reshape( (/ 45_xi, 35_xi, 32_xi, 32_xi, 48_xi, 33_xi /), &
228  & (/ num_indices, num_lists /)), &
229  global_size(ndim) = (/ 5_xi, 4_xi, 3_xi /), &
230  global_start_index = 1
231  TYPE(xt_idxlist) :: idxlists(num_lists), collectionlist
232  TYPE(xt_bounds) :: bounds(ndim)
233  TYPE(xt_bounds), PARAMETER :: bounds_ref(ndim) = (/ xt_bounds(2, 2), &
234  xt_bounds(2, 2), xt_bounds(1, 2) /)
235  INTEGER :: i
236 
237  DO i = 1, num_lists
238  idxlists(i) = xt_idxvec_new(indices(:, i), SIZE(indices, 1))
239  END DO
240  collectionlist = xt_idxlist_collection_new(idxlists)
241  CALL xt_idxlist_delete(idxlists)
242 
243  bounds = xt_idxlist_get_bounding_box(collectionlist, global_size, &
244  global_start_index)
245  CALL xt_idxlist_delete(collectionlist)
246  IF (any(bounds /= bounds_ref)) &
247  CALL test_abort("ERROR: unexpected boundaries", filename, __line__)
248  END SUBROUTINE test_bounding_box2
249 
250 END PROGRAM test_idxlist_collection_f
251 !
252 ! Local Variables:
253 ! f90-continuation-indent: 5
254 ! coding: utf-8
255 ! indent-tabs-mode: nil
256 ! show-trailing-whitespace: t
257 ! require-trailing-newline: t
258 ! End:
259 !
Definition: yaxt.f90:49
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
Xt_idxlist xt_idxempty_new(void)
Definition: xt_idxempty.c:165
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:332
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:74
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:163