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