Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
xt_xmap_intersection_f.f90
Go to the documentation of this file.
1
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
51
52#include "fc_feature_defs.inc"
53MODULE xt_xmap_intersection
54 USE iso_c_binding, ONLY: c_int, c_loc, c_null_ptr, c_ptr
55 USE xt_core, ONLY: xt_abort, xt_mpi_fint_kind
56 USE xt_idxlist_abstract, ONLY: xt_idxlist, xt_idxlist_f2c
57 USE xt_xmap_abstract, ONLY: xt_xmap, xt_xmap_c2f
58#include "xt_slice_c_loc.inc"
59 IMPLICIT NONE
60 PRIVATE
61
62 TYPE, BIND(c), PUBLIC :: xt_com_list
63 TYPE(xt_idxlist) :: list
64 INTEGER(c_int) :: rank
65 END TYPE xt_com_list
66
67 TYPE, PUBLIC :: xt_com_pos
68 INTEGER, POINTER :: transfer_pos(:)
69 INTEGER :: rank
70 END TYPE xt_com_pos
71
72 TYPE, BIND(c) :: xt_com_pos_c
73 TYPE(c_ptr) :: transfer_pos
74 INTEGER(c_int) :: num_transfer_pos
75 INTEGER(c_int) :: rank
76 END TYPE xt_com_pos_c
77
80
81 INTERFACE
82 FUNCTION xmi_new_f2c(num_src_intersections, src_com, &
83 num_dst_intersections, dst_com, &
84 src_idxlist, dst_idxlist, comm) RESULT(xmap) &
85 bind(c, name='xt_xmap_intersection_new_f2c')
86 IMPORT :: c_int, c_ptr, xt_mpi_fint_kind
87 INTEGER(c_int), VALUE, INTENT(in) :: num_src_intersections, &
88 num_dst_intersections
89 TYPE(c_ptr), VALUE, INTENT(in) :: src_com, dst_com, src_idxlist, &
90 dst_idxlist
91 INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: comm
92 TYPE(c_ptr) :: xmap
93 END FUNCTION xmi_new_f2c
94
95 FUNCTION xmi_ext_new_f2c(num_src_intersections, src_com, &
96 num_dst_intersections, dst_com, &
97 src_idxlist, dst_idxlist, comm) RESULT(xmap) &
98 bind(c, name='xt_xmap_intersection_ext_new_f2c')
99 IMPORT :: c_int, c_ptr, xt_mpi_fint_kind
100 INTEGER(c_int), VALUE, INTENT(in) :: num_src_intersections, &
101 num_dst_intersections
102 TYPE(c_ptr), VALUE, INTENT(in) :: src_com, dst_com, src_idxlist, &
103 dst_idxlist
104 INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: comm
105 TYPE(c_ptr) :: xmap
106 END FUNCTION xmi_ext_new_f2c
107
108 FUNCTION xmi_pos_new_f2c(num_src_msg, src_com, num_dst_msg, dst_com, comm) &
109 result(xmap) &
110 bind(c, name='xt_xmap_intersection_pos_new_f2c')
111 IMPORT :: c_int, c_ptr, xt_mpi_fint_kind, xt_com_pos_c
112 INTEGER(c_int), VALUE, INTENT(in) :: num_src_msg, num_dst_msg
113 TYPE(xt_com_pos_c), INTENT(in) :: src_com(*), dst_com(*)
114 INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: comm
115 TYPE(c_ptr) :: xmap
116 END FUNCTION xmi_pos_new_f2c
117 END INTERFACE
118
120 MODULE PROCEDURE xmi_new_i_a_i_a
121 MODULE PROCEDURE xmi_new_a_a
122 END INTERFACE xt_xmap_intersection_new
123
125 MODULE PROCEDURE xmi_ext_new_i_a_i_a
126 MODULE PROCEDURE xmi_ext_new_a_a
127 END INTERFACE xt_xmap_intersection_ext_new
128
130 MODULE PROCEDURE xmi_pos_new_a_a
131 MODULE PROCEDURE xmi_pos_new_i_a_i_a
132 END INTERFACE xt_xmap_intersection_pos_new
133
134 CHARACTER(len=*), PARAMETER :: filename = 'xt_xmap_intersection_f.f90'
135CONTAINS
136 FUNCTION xmi_new_i_a_i_a(num_src_intersections, src_com, &
137 num_dst_intersections, dst_com, &
138 src_idxlist, dst_idxlist, comm) RESULT(xmap)
139 INTEGER(c_int), VALUE, INTENT(in) :: num_src_intersections, &
140 num_dst_intersections
141 TYPE(xt_com_list), TARGET, INTENT(in) :: src_com(num_src_intersections), &
142 dst_com(num_dst_intersections)
143 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
144 INTEGER, INTENT(in) :: comm
145 TYPE(xt_xmap) :: xmap
146 TYPE(c_ptr) :: src_com_p, dst_com_p
147
148 IF (num_src_intersections > 0) THEN
149 src_com_p = c_loc(src_com)
150 ELSE
151 src_com_p = c_null_ptr
152 END IF
153 IF (num_dst_intersections > 0) THEN
154 dst_com_p = c_loc(dst_com)
155 ELSE
156 dst_com_p = c_null_ptr
157 END IF
158 xmap = xt_xmap_c2f(xmi_new_f2c(&
159 num_src_intersections, src_com_p, &
160 num_dst_intersections, dst_com_p, &
161 xt_idxlist_f2c(src_idxlist), xt_idxlist_f2c(dst_idxlist), comm))
162 END FUNCTION xmi_new_i_a_i_a
163
164 FUNCTION xmi_new_a_a(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
165 result(xmap)
166 TYPE(xt_com_list), TARGET, INTENT(in) :: src_com(:), dst_com(:)
167 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
168 INTEGER, INTENT(in) :: comm
169 TYPE(xt_xmap) :: xmap
170
171 TYPE(xt_com_list), ALLOCATABLE, TARGET :: src_com_a(:), dst_com_a(:)
172 TYPE(c_ptr) :: src_com_p, dst_com_p
173 INTEGER(c_int) :: num_src_intersections_c, num_dst_intersections_c
174 num_src_intersections_c = int(SIZE(src_com), c_int)
175 num_dst_intersections_c = int(SIZE(dst_com), c_int)
176 CALL com_p_arg(src_com, src_com_a, src_com_p)
177 CALL com_p_arg(dst_com, dst_com_a, dst_com_p)
178
179 xmap = xt_xmap_c2f(xmi_new_f2c(num_src_intersections_c, src_com_p, &
180 num_dst_intersections_c, dst_com_p, &
181 xt_idxlist_f2c(src_idxlist), xt_idxlist_f2c(dst_idxlist), comm))
182 END FUNCTION xmi_new_a_a
183
184 FUNCTION xmi_ext_new_i_a_i_a(num_src_intersections, src_com, &
185 num_dst_intersections, dst_com, &
186 src_idxlist, dst_idxlist, comm) RESULT(xmap)
187 INTEGER(c_int), VALUE, INTENT(in) :: num_src_intersections, &
188 num_dst_intersections
189 TYPE(xt_com_list), TARGET, INTENT(in) :: src_com(num_src_intersections), &
190 dst_com(num_dst_intersections)
191 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
192 INTEGER, INTENT(in) :: comm
193 TYPE(xt_xmap) :: xmap
194 INTEGER(c_int) :: num_src_intersections_c, num_dst_intersections_c
195 num_src_intersections_c = int(num_src_intersections, c_int)
196 num_dst_intersections_c = int(num_dst_intersections, c_int)
197
198 xmap = xt_xmap_c2f(xmi_ext_new_f2c(&
199 num_src_intersections_c, c_loc(src_com), &
200 num_dst_intersections_c, c_loc(dst_com), &
201 xt_idxlist_f2c(src_idxlist), xt_idxlist_f2c(dst_idxlist), comm))
202 END FUNCTION xmi_ext_new_i_a_i_a
203
204 FUNCTION xmi_ext_new_a_a(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
205 result(xmap)
206 TYPE(xt_com_list), TARGET, INTENT(in) :: src_com(:), dst_com(:)
207 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
208 INTEGER, INTENT(in) :: comm
209 TYPE(xt_xmap) :: xmap
210
211 TYPE(xt_com_list), ALLOCATABLE, TARGET :: src_com_a(:), dst_com_a(:)
212 TYPE(c_ptr) :: src_com_p, dst_com_p
213 INTEGER(c_int) :: num_src_intersections_c, num_dst_intersections_c
214 num_src_intersections_c = int(SIZE(src_com), c_int)
215 num_dst_intersections_c = int(SIZE(dst_com), c_int)
216
217 CALL com_p_arg(src_com, src_com_a, src_com_p)
218 CALL com_p_arg(dst_com, dst_com_a, dst_com_p)
219
220 xmap = xt_xmap_c2f(xmi_ext_new_f2c(&
221 num_src_intersections_c, src_com_p, &
222 num_dst_intersections_c, dst_com_p, &
223 xt_idxlist_f2c(src_idxlist), xt_idxlist_f2c(dst_idxlist), comm))
224 END FUNCTION xmi_ext_new_a_a
225
226 FUNCTION xmi_pos_new_i_a_i_a( &
227 num_src_msg, src_com, num_dst_msg, dst_com, comm) RESULT(xmap)
228 TYPE(xt_com_pos), TARGET, INTENT(in) :: src_com(:), dst_com(:)
229 INTEGER, INTENT(in) :: num_src_msg, num_dst_msg
230 INTEGER, INTENT(in) :: comm
231 TYPE(xt_xmap) :: xmap
232
233 INTEGER(c_int) :: num_src_msg_c, num_dst_msg_c
234 TYPE(xt_com_pos_c), ALLOCATABLE :: src_com_c(:), dst_com_c(:)
235 INTEGER(c_int), TARGET, ALLOCATABLE :: pos_buffer(:)
236 INTEGER :: pos_buffer_offset, size_pos_buf
237
238 size_pos_buf = num_pos_copy(num_src_msg, src_com) + &
239 num_pos_copy(num_dst_msg, dst_com)
240 ALLOCATE(pos_buffer(size_pos_buf))
241
242 num_src_msg_c = int(num_src_msg, c_int)
243 num_dst_msg_c = int(num_dst_msg, c_int)
244
245 pos_buffer_offset = 0
246 CALL generate_xt_com_pos_c(num_src_msg, src_com, src_com_c, &
247 size_pos_buf, pos_buffer, pos_buffer_offset)
248 CALL generate_xt_com_pos_c(num_dst_msg, dst_com, dst_com_c, &
249 size_pos_buf, pos_buffer, pos_buffer_offset)
250
251 xmap = &
252 xt_xmap_c2f(xmi_pos_new_f2c(&
253 num_src_msg_c, src_com_c, num_dst_msg_c, dst_com_c, comm))
254
255 END FUNCTION xmi_pos_new_i_a_i_a
256
257 PURE FUNCTION num_pos_copy(num_msg, com_pos) RESULT(total_num_pos)
258 INTEGER, INTENT(in) :: num_msg
259 TYPE(xt_com_pos), INTENT(in) :: com_pos(:)
260 INTEGER :: i
261 INTEGER :: total_num_pos
262#if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
263 INTEGER, POINTER :: pos(:)
264#endif
265 total_num_pos = 0
266#ifdef HAVE_FC_IS_CONTIGUOUS
267 IF (kind(com_pos(i)%transfer_pos) == c_int) THEN
268 DO i = 1, num_msg
269#if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
270 pos => com_pos(i)%transfer_pos
271 IF (.NOT. is_contiguous(pos)) THEN
272#else
273 IF (.NOT. is_contiguous(com_pos(i)%transfer_pos)) THEN
274#endif
275 total_num_pos = total_num_pos &
276 + SIZE(com_pos(i)%transfer_pos)
277 END IF
278 END DO
279 ELSE
280#endif
281 DO i = 1, num_msg
282 total_num_pos = total_num_pos + SIZE(com_pos(i)%transfer_pos)
283 END DO
284#ifdef HAVE_FC_IS_CONTIGUOUS
285 ENDIF
286#endif
287 END FUNCTION num_pos_copy
288
289 SUBROUTINE generate_xt_com_pos_c(num_msg, com_pos, com_pos_c, &
290 size_pos_buf, pos_buffer, &
291 pos_buffer_offset)
292 INTEGER, INTENT(in) :: num_msg
293 TYPE(xt_com_pos), TARGET, INTENT(in) :: com_pos(:)
294 TYPE(xt_com_pos_c), ALLOCATABLE, INTENT(out) :: com_pos_c(:)
295 INTEGER, INTENT(in) :: size_pos_buf
296 INTEGER(c_int), TARGET, INTENT(inout) :: pos_buffer(size_pos_buf)
297 INTEGER, INTENT(inout) :: pos_buffer_offset
298 INTEGER :: i, j, num_pos
299#if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
300 INTEGER, POINTER :: pos(:)
301#endif
302 ALLOCATE(com_pos_c(num_msg))
303
304 DO i = 1, num_msg
305 num_pos = SIZE(com_pos(i)%transfer_pos)
306#ifdef HAVE_FC_IS_CONTIGUOUS
307# if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
308 pos => com_pos(i)%transfer_pos
309 IF (kind(1) == c_int .AND. is_contiguous(pos)) THEN
310# else
311 IF (kind(1) == c_int .AND. is_contiguous(com_pos(i)%transfer_pos)) THEN
312# endif
313 com_pos_c(i)%transfer_pos = c_loc(com_pos(i)%transfer_pos(1))
314 ELSE
315#endif
316 DO j = 1, num_pos
317 pos_buffer(pos_buffer_offset + j) = &
318 int(com_pos(i)%transfer_pos(j), c_int)
319 END DO
320 com_pos_c(i)%transfer_pos = c_loc(pos_buffer(pos_buffer_offset+1))
321 pos_buffer_offset = pos_buffer_offset + num_pos
322#ifdef HAVE_FC_IS_CONTIGUOUS
323 END IF
324#endif
325 com_pos_c(i)%num_transfer_pos = int(num_pos, c_int)
326 com_pos_c(i)%rank = int(com_pos(i)%rank, c_int)
327 END DO
328
329 END SUBROUTINE generate_xt_com_pos_c
330
331 FUNCTION xmi_pos_new_a_a(src_com, dst_com, comm) RESULT(xmap)
332 TYPE(xt_com_pos), INTENT(in) :: src_com(:), dst_com(:)
333 INTEGER, INTENT(in) :: comm
334 TYPE(xt_xmap) :: xmap
335
336 xmap = &
337 xmi_pos_new_i_a_i_a(SIZE(src_com), src_com, SIZE(dst_com), dst_com, comm)
338 END FUNCTION xmi_pos_new_a_a
339
340 SUBROUTINE com_p_arg(com, com_a, com_p)
341 TYPE(xt_com_list), TARGET, INTENT(in) :: com(:)
342 TYPE(xt_com_list), TARGET, ALLOCATABLE, INTENT(inout) :: com_a(:)
343 TYPE(c_ptr), INTENT(out) :: com_p
344
345 INTEGER :: com_size
346 LOGICAL :: com_is_contiguous
347#ifndef HAVE_FC_IS_CONTIGUOUS
348 INTERFACE
349 FUNCTION xt_com_list_contiguous(com_a, com_b) RESULT(p) &
350 bind(c, name='xt_com_list_contiguous')
351 IMPORT :: c_int, xt_com_list
352 TYPE(xt_com_list), INTENT(in) :: com_a, com_b
353 INTEGER(c_int) :: p
354 END FUNCTION xt_com_list_contiguous
355 END INTERFACE
356#endif
357
358 com_size = SIZE(com)
359 IF (com_size > huge(1_c_int)) &
360 CALL xt_abort('invalid size', filename, __line__)
361 IF (com_size > 0) THEN
362 IF (com_size > 1) THEN
363#ifdef HAVE_FC_IS_CONTIGUOUS
364 com_is_contiguous = is_contiguous(com)
365#else
366 com_is_contiguous = xt_com_list_contiguous(com(1), com(2)) /= 0
367#endif
368 IF (com_is_contiguous) THEN
369 xt_slice_c_loc(com(1), com_p)
370 ELSE
371 ALLOCATE(com_a(com_size))
372 com_a = com
373 com_p = c_loc(com_a)
374 END IF
375 ELSE
376 xt_slice_c_loc(com(1), com_p)
377 END IF
378 ELSE
379 com_p = c_null_ptr
380 END IF
381 END SUBROUTINE com_p_arg
382
383END MODULE xt_xmap_intersection
384!
385! Local Variables:
386! f90-continuation-indent: 5
387! coding: utf-8
388! indent-tabs-mode: nil
389! show-trailing-whitespace: t
390! require-trailing-newline: t
391! End:
392!
Xt_xmap xt_xmap_intersection_ext_new(int num_src_intersections, const struct Xt_com_list src_com[num_src_intersections], int num_dst_intersections, const struct Xt_com_list dst_com[num_dst_intersections], Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)
Xt_xmap xt_xmap_intersection_pos_new(int num_src_msg, const struct Xt_com_pos src_com[num_src_msg], int num_dst_msg, const struct Xt_com_pos dst_com[num_dst_msg], MPI_Comm comm)
Xt_xmap xt_xmap_intersection_new(int num_src_intersections, const struct Xt_com_list src_com[num_src_intersections], int num_dst_intersections, const struct Xt_com_list dst_com[num_dst_intersections], Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)
PPM_DSO_INTERNAL int xt_com_list_contiguous(const struct Xt_com_list *p_com_a, const struct Xt_com_list *p_com_b)
Definition yaxt_f2c.c:617
Xt_idxlist xt_idxlist_f2c(struct xt_idxlist_f *p)
Definition yaxt_f2c.c:180