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
57 USE xt_xmap_abstract,
ONLY:
xt_xmap, xt_xmap_c2f
58#include "xt_slice_c_loc.inc"
62 TYPE,
BIND(c),
PUBLIC :: xt_com_list
64 INTEGER(c_int) :: rank
68 INTEGER,
POINTER :: transfer_pos(:)
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
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, &
89 TYPE(c_ptr),
VALUE,
INTENT(in) :: src_com, dst_com, src_idxlist, &
91 INTEGER(xt_mpi_fint_kind),
VALUE,
INTENT(in) :: comm
93 END FUNCTION xmi_new_f2c
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, &
104 INTEGER(xt_mpi_fint_kind),
VALUE,
INTENT(in) :: comm
106 END FUNCTION xmi_ext_new_f2c
108 FUNCTION xmi_pos_new_f2c(num_src_msg, src_com, num_dst_msg, dst_com, comm) &
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
116 END FUNCTION xmi_pos_new_f2c
120 MODULE PROCEDURE xmi_new_i_a_i_a
121 MODULE PROCEDURE xmi_new_a_a
125 MODULE PROCEDURE xmi_ext_new_i_a_i_a
126 MODULE PROCEDURE xmi_ext_new_a_a
130 MODULE PROCEDURE xmi_pos_new_a_a
131 MODULE PROCEDURE xmi_pos_new_i_a_i_a
134 CHARACTER(len=*),
PARAMETER :: filename =
'xt_xmap_intersection_f.f90'
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
146 TYPE(c_ptr) :: src_com_p, dst_com_p
148 IF (num_src_intersections > 0)
THEN
149 src_com_p = c_loc(src_com)
151 src_com_p = c_null_ptr
153 IF (num_dst_intersections > 0)
THEN
154 dst_com_p = c_loc(dst_com)
156 dst_com_p = c_null_ptr
158 xmap = xt_xmap_c2f(xmi_new_f2c(&
159 num_src_intersections, src_com_p, &
160 num_dst_intersections, dst_com_p, &
162 END FUNCTION xmi_new_i_a_i_a
164 FUNCTION xmi_new_a_a(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
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
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)
179 xmap = xt_xmap_c2f(xmi_new_f2c(num_src_intersections_c, src_com_p, &
180 num_dst_intersections_c, dst_com_p, &
182 END FUNCTION xmi_new_a_a
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
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)
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), &
202 END FUNCTION xmi_ext_new_i_a_i_a
204 FUNCTION xmi_ext_new_a_a(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
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
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)
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)
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, &
224 END FUNCTION xmi_ext_new_a_a
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
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
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))
242 num_src_msg_c = int(num_src_msg, c_int)
243 num_dst_msg_c = int(num_dst_msg, c_int)
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)
252 xt_xmap_c2f(xmi_pos_new_f2c(&
253 num_src_msg_c, src_com_c, num_dst_msg_c, dst_com_c, comm))
255 END FUNCTION xmi_pos_new_i_a_i_a
257 PURE FUNCTION num_pos_copy(num_msg, com_pos)
RESULT(total_num_pos)
258 INTEGER,
INTENT(in) :: num_msg
261 INTEGER :: total_num_pos
262#if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
263 INTEGER,
POINTER :: pos(:)
266#ifdef HAVE_FC_IS_CONTIGUOUS
267 IF (kind(com_pos(i)%transfer_pos) == c_int)
THEN
269#if defined __PGI && __PGIC__ > 15 && __PGIC__ <= 20
270 pos => com_pos(i)%transfer_pos
271 IF (.NOT. is_contiguous(pos))
THEN
273 IF (.NOT. is_contiguous(com_pos(i)%transfer_pos))
THEN
275 total_num_pos = total_num_pos &
276 +
SIZE(com_pos(i)%transfer_pos)
282 total_num_pos = total_num_pos +
SIZE(com_pos(i)%transfer_pos)
284#ifdef HAVE_FC_IS_CONTIGUOUS
287 END FUNCTION num_pos_copy
289 SUBROUTINE generate_xt_com_pos_c(num_msg, com_pos, com_pos_c, &
290 size_pos_buf, pos_buffer, &
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(:)
302 ALLOCATE(com_pos_c(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
311 IF (kind(1) == c_int .AND. is_contiguous(com_pos(i)%transfer_pos))
THEN
313 com_pos_c(i)%transfer_pos = c_loc(com_pos(i)%transfer_pos(1))
317 pos_buffer(pos_buffer_offset + j) = &
318 int(com_pos(i)%transfer_pos(j), c_int)
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
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)
329 END SUBROUTINE generate_xt_com_pos_c
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
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
340 SUBROUTINE com_p_arg(com, com_a, com_p)
342 TYPE(
xt_com_list),
TARGET,
ALLOCATABLE,
INTENT(inout) :: com_a(:)
343 TYPE(c_ptr),
INTENT(out) :: com_p
346 LOGICAL :: com_is_contiguous
347#ifndef HAVE_FC_IS_CONTIGUOUS
350 bind(c, name=
'xt_com_list_contiguous')
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)
368 IF (com_is_contiguous)
THEN
369 xt_slice_c_loc(com(1), com_p)
371 ALLOCATE(com_a(com_size))
376 xt_slice_c_loc(com(1), com_p)
381 END SUBROUTINE com_p_arg
383END MODULE xt_xmap_intersection
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)
Xt_idxlist xt_idxlist_f2c(struct xt_idxlist_f *p)