Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
unstruct_halo_exchange_f.f90
1
9
10!
11! Keywords:
12! Maintainer: Moritz Hanke <hanke@dkrz.de>
13! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
14!
15! Redistribution and use in source and binary forms, with or without
16! modification, are permitted provided that the following conditions are
17! met:
18!
19! Redistributions of source code must retain the above copyright notice,
20! this list of conditions and the following disclaimer.
21!
22! Redistributions in binary form must reproduce the above copyright
23! notice, this list of conditions and the following disclaimer in the
24! documentation and/or other materials provided with the distribution.
25!
26! Neither the name of the DKRZ GmbH nor the names of its contributors
27! may be used to endorse or promote products derived from this software
28! without specific prior written permission.
29!
30! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
31! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
32! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
33! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
34! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
35! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
36! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
37! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
38! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
39! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
40! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
41!
42
43 ! This program demonstrates the halo exchange for unstructured data that is
44 ! distributed among three processes. The "global" grid looks as follows
45 ! (The numbers represent the indices of the corners of the grid.)
46 !
47 ! 01------04------08------13
48 ! / \ / \ / \ / \
49 ! / \ / \ / \ / \
50 ! 00------03------07------12------17
51 ! \ / \ / \ / \ /
52 ! \ / \ / \ / \ /
53 ! 02------06------11------16
54 ! \ / \ / \ /
55 ! \ / \ / \ /
56 ! 05------10------15
57 ! \ / \ /
58 ! \ / \ /
59 ! 09------14
60 !
61 ! Each process has a part of this grid plus a halo around it (marked with '*').
62 !
63 ! Process 0 (halo points: 8, 12, 11 10, 5):
64 !
65 ! 01------04******08
66 ! / \ / \ * *
67 ! / \ / \ * *
68 ! 00------03------07******12
69 ! \ / \ / * *
70 ! \ / \ / * *
71 ! 02------06******11
72 ! * * * *
73 ! * * * *
74 ! 05******10
75 !
76 ! Process 1 (halo points: 4, 3, 6, 10, 15):
77 !
78 ! 04******08------13
79 ! * * / \ / \
80 ! * * / \ / \
81 ! 03******07------12------17
82 ! * * \ / \ /
83 ! * * \ / \ /
84 ! 06******11------16
85 ! * * * *
86 ! * * * *
87 ! 10******15
88 !
89 ! Process 2 (halo points: 3, 7, 12, 2, 16)
90 !
91 ! 03******07******12
92 ! * * * * * *
93 ! * * * * * *
94 ! 02******06------11******16
95 ! * / \ / \ *
96 ! * / \ / \ *
97 ! 05------10------15
98 ! \ / \ /
99 ! \ / \ /
100 ! 09------14
101#include "fc_feature_defs.inc"
102PROGRAM unstruct_halo_exchang
103 USE mpi
104 USE yaxt, ONLY: xt_initialize, xt_finalize, &
108 xt_redist_s_exchange, xi => xt_int_kind
109 ! PGI compilers do not handle generic interface correctly
110#if defined __PGI && ( __PGIC__ == 15 || __PGIC__ == 14 )
111 USE xt_redist_real_sp, ONLY: xt_redist_s_exchange
112 USE xt_redist_real_dp, ONLY: xt_redist_s_exchange
113#endif
114 IMPLICIT NONE
115
116 INTEGER :: comm_rank, comm_size
117 INTEGER :: i, j, rank, ierror
118
119 INTEGER(xi) :: local_indices(12, 0:2), idx
120 INTEGER(xi) :: halo_indices(5, 0:2)
121 INTEGER(xi) :: src_indices(12, 0:2), tgt_indices(5, 0:2)
122 INTEGER :: src_offsets(12)
123 INTEGER :: tgt_offsets(5)
124
125 TYPE(xt_idxlist) :: src_idxlist, tgt_idxlist
126 TYPE(xt_xmap) :: xmap
127 TYPE(xt_redist) :: redist
128 DOUBLE PRECISION :: src_data(12), tgt_data(12)
129
130 CHARACTER(64) :: fmt
131
132 CALL mpi_init(ierror)
133 IF (ierror /= mpi_success) stop 1
134 CALL xt_initialize(mpi_comm_world)
135 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
136 IF (ierror /= mpi_success) stop 1
137 CALL mpi_comm_size (mpi_comm_world, comm_size, ierror)
138 IF (ierror /= mpi_success) stop 1
139
140 IF (comm_size /= 3) stop 3
141
142 ! create description of locally stored indices...
143 local_indices(:,0) = (/ 1_xi, 4_xi, 8_xi, &
144 & 0_xi, 3_xi, 7_xi, 12_xi, &
145 & 2_xi, 6_xi, 11_xi, &
146 & 5_xi, 10_xi /)
147 local_indices(:,1) = (/ 4_xi, 8_xi, 13_xi, &
148 & 3_xi, 7_xi, 12_xi, 17_xi, &
149 & 6_xi, 11_xi, 16_xi, &
150 & 10_xi, 15_xi /)
151 local_indices(:,2) = (/ 3_xi, 7_xi, 12_xi, &
152 & 2_xi, 6_xi, 11_xi, 16_xi, &
153 & 5_xi, 10_xi, 15_xi, &
154 & 9_xi, 14_xi /)
155
156 ! ...and list of which of those are shadows of data "owned" by another rank
157 halo_indices(:,0) = (/ 8_xi, 12_xi, 11_xi, 10_xi, 5_xi /)
158 halo_indices(:,1) = (/ 4_xi, 3_xi, 6_xi, 10_xi, 15_xi /)
159 halo_indices(:,2) = (/ 3_xi, 7_xi, 12_xi, 2_xi, 16_xi /)
160
161 DO rank = 0, comm_size - 1
162 DO i = 1, SIZE(local_indices, 1)
163 idx = local_indices(i, rank)
164 src_indices(i, rank) = merge(-1_xi, idx, any(halo_indices(:, rank) == idx))
165 END DO
166 tgt_indices(:, rank) = halo_indices(:, rank)
167 END DO
168
169 ! create decomposition descriptors
170 src_idxlist = xt_idxvec_new(src_indices(:,comm_rank), SIZE(src_indices, 1))
171 tgt_idxlist = xt_idxvec_new(tgt_indices(:,comm_rank), SIZE(tgt_indices, 1))
172
173 ! generate exchange map
174 xmap = xt_xmap_all2all_new(src_idxlist, tgt_idxlist, mpi_comm_world)
175
176 ! generate redistribution object
177 src_offsets = (/(i, i = 0, SIZE(src_indices, 1) - 1)/)
178 DO i = 1, SIZE(halo_indices, 1)
179 DO j = 1, SIZE(local_indices, 1)
180 IF (halo_indices(i, comm_rank) == local_indices(j, comm_rank)) &
181 tgt_offsets(i) = j - 1
182 END DO
183 END DO
184 redist = xt_redist_p2p_off_new(xmap, src_offsets, tgt_offsets, &
185 & mpi_double_precision)
186
187 ! prepare arrays
188 src_data(:) = dble(src_indices(:,comm_rank))
189 tgt_data(:) = dble(src_indices(:,comm_rank))
190
191 fmt = '(I1, " ", A, " exchange: ", xx(I3))'
192 WRITE(fmt(29:30), '(I2)') SIZE(src_data, 1)
193 print fmt, comm_rank, 'before', int(src_data(:))
194
195 ! do the exchange
196 CALL xt_redist_s_exchange(redist, src_data, tgt_data)
197
198 print fmt, comm_rank, 'after ', int(tgt_data(:))
199
200 ! clean up
201 CALL xt_redist_delete(redist)
202 CALL xt_xmap_delete(xmap)
203 CALL xt_idxlist_delete(tgt_idxlist)
204 CALL xt_idxlist_delete(src_idxlist)
205
206 ! finalise
207 CALL xt_finalize()
208 CALL mpi_finalize(ierror)
209 IF (ierror /= mpi_success) stop 1
210END PROGRAM unstruct_halo_exchang
211!
212! Local Variables:
213! coding: utf-8
214! f90-continuation-indent: 5
215! indent-tabs-mode: nil
216! show-trailing-whitespace: t
217! require-trailing-newline: t
218! license-project-url: "https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/"
219! license-default: "bsd"
220! End:
221!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition xt_idxvec.c:213
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
Xt_redist xt_redist_p2p_off_new(Xt_xmap xmap, const int *src_offsets, const int *dst_offsets, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)