Yet Another eXchange Tool  0.9.0
unstruct_halo_exchange_f.f90
1 
9 
10 !
11 ! Keywords:
12 ! Maintainer: Moritz Hanke <hanke@dkrz.de>
13 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
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 
102 PROGRAM unstruct_halo_exchang
103  USE mpi
104  USE yaxt, ONLY: xt_initialize, xt_finalize, &
105  xt_idxlist, xt_idxvec_new, xt_idxlist_delete, &
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 )
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
210 END PROGRAM unstruct_halo_exchang
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
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition: xt_idxvec.c:163
void xt_redist_delete(Xt_redist redist)
Definition: xt_redist.c:68
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
Definition: xt_redist.c:73
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:85
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)