1 | ! Module for MPI communication of field halos |
---|
2 | ! This module uses Fortran 2003 features : move_alloc intrinsic, pointer bounds remapping, allocatable type fields |
---|
3 | module transfert_mpi_mod |
---|
4 | use abort_mod, only : dynamico_abort, abort_acc |
---|
5 | use profiling_mod, only : enter_profile, exit_profile, register_id |
---|
6 | use domain_mod, only : ndomain, ndomain_glo, domain, domain_glo, domloc_glo_ind, domglo_rank, domglo_loc_ind |
---|
7 | use field_mod, only : t_field, field_T, field_U, field_Z |
---|
8 | use transfert_request_mod |
---|
9 | implicit none |
---|
10 | private |
---|
11 | |
---|
12 | ! Describes how to pack/unpack a message from a local domain to another |
---|
13 | type t_local_submessage |
---|
14 | integer :: src_ind_loc, dest_ind_loc ! index of local and remote domain |
---|
15 | integer :: npoints ! Number of cells to transfer (dim12) |
---|
16 | integer, allocatable :: displ_src(:) ! List of indexes to copy from domain src_ind_loc |
---|
17 | integer, allocatable :: displ_dest(:) ! List of indexes to copy to domain dest_ind_loc |
---|
18 | integer, allocatable :: sign(:) ! Sign change to be applied for vector requests |
---|
19 | end type |
---|
20 | |
---|
21 | ! Describes how to pack/unpack a message from a domain to another, and contains MPI buffer |
---|
22 | type t_submessage |
---|
23 | integer :: ind_loc, remote_ind_glo, remote_rank ! index of local and remote domain |
---|
24 | integer :: npoints ! Number of cells to transfer (dim12) |
---|
25 | integer, allocatable :: displs(:) ! List of indexes to copy from field to buffer for each level |
---|
26 | integer, allocatable :: sign(:) ! Sign change to be applied for vector requests |
---|
27 | integer :: mpi_buffer_displ = -1 |
---|
28 | end type |
---|
29 | |
---|
30 | type mpi_buffer_t |
---|
31 | integer :: n |
---|
32 | real, allocatable :: buff(:) |
---|
33 | end type |
---|
34 | |
---|
35 | ! Describes how to exchange data for a field. |
---|
36 | type t_message |
---|
37 | type (t_field), pointer :: field(:) => null() ! Field to exchange |
---|
38 | type (t_request), pointer :: request(:) => null() ! Type of message to send |
---|
39 | type (t_local_submessage), pointer :: message_local(:) ! Local halo copies |
---|
40 | type (t_submessage), pointer :: message_in(:) ! Messages to recieve from remote ranks and to copy back to the field |
---|
41 | type (t_submessage), pointer :: message_out(:) ! Halos to copy to MPI buffer and to send to remote ranks |
---|
42 | type (mpi_buffer_t), pointer :: mpi_buffer_in(:) |
---|
43 | type (mpi_buffer_t), pointer :: mpi_buffer_out(:) |
---|
44 | integer, pointer :: mpi_requests_in(:) ! MPI requests used for message_in. |
---|
45 | integer, pointer :: mpi_requests_out(:) ! MPI requests used for message_out. |
---|
46 | ! NOTE : requests are persistant requests initialized in init_message. MPI_Start and MPI_Wait are then used to initiate and complete communications. |
---|
47 | ! ex : Give mpi_requests_in(i) to MPI_Start to send the buffer contained in message_in(i) |
---|
48 | integer :: send_seq ! Sequence number : send_seq is incremented each time send_message is called |
---|
49 | integer :: wait_seq ! Sequence number : wait_seq is incremented each time wait_message is called |
---|
50 | logical :: ondevice ! Ready to transfer ondevice field |
---|
51 | end type t_message |
---|
52 | |
---|
53 | public :: t_message, t_request, & |
---|
54 | req_i1, req_e1_scal, req_e1_vect, & |
---|
55 | req_i0, req_e0_scal, req_e0_vect, & |
---|
56 | req_z1_scal, & |
---|
57 | init_transfert, & |
---|
58 | init_message, & |
---|
59 | finalize_message, & |
---|
60 | send_message, & |
---|
61 | wait_message, & |
---|
62 | test_message |
---|
63 | |
---|
64 | ! ---- Private variables ---- |
---|
65 | ! Profiling id for mpi |
---|
66 | integer :: profile_mpi, profile_mpi_copies, profile_mpi_waitall, profile_mpi_barrier |
---|
67 | contains |
---|
68 | ! Initialize transfert : must be called before any other transfert_mpi routines |
---|
69 | subroutine init_transfert |
---|
70 | use mpi_mod, only : MPI_THREAD_SINGLE, MPI_THREAD_FUNNELED |
---|
71 | use mpipara, only : mpi_threading_mode |
---|
72 | use profiling_mod, only : register_id |
---|
73 | logical, parameter :: profile_mpi_detail = .true. |
---|
74 | |
---|
75 | !$omp master |
---|
76 | ! Check requested threads support |
---|
77 | if( mpi_threading_mode /= MPI_THREAD_SINGLE .and. mpi_threading_mode /= MPI_THREAD_FUNNELED ) call dynamico_abort("Only single and funneled threading mode are supported.") |
---|
78 | |
---|
79 | ! Register profiling ids |
---|
80 | call register_id("MPI", profile_mpi) |
---|
81 | if( profile_mpi_detail ) then |
---|
82 | call register_id("MPI_copies", profile_mpi_copies) |
---|
83 | call register_id("MPI_waitall", profile_mpi_waitall) |
---|
84 | call register_id("MPI_omp_barrier", profile_mpi_barrier) |
---|
85 | else |
---|
86 | profile_mpi_copies = profile_mpi |
---|
87 | profile_mpi_waitall = profile_mpi |
---|
88 | profile_mpi_barrier = profile_mpi |
---|
89 | endif |
---|
90 | |
---|
91 | ! Initialize requests |
---|
92 | call init_all_requests() |
---|
93 | !$omp end master |
---|
94 | !$omp barrier |
---|
95 | end subroutine |
---|
96 | |
---|
97 | subroutine init_message(field, request, message, name) |
---|
98 | use mpi_mod |
---|
99 | use mpipara |
---|
100 | type(t_field), pointer, intent(in) :: field(:) |
---|
101 | type(t_request),pointer, intent(in) :: request(:) |
---|
102 | type(t_message), target, intent(out) :: message ! Needs intent out for call to finalize_message |
---|
103 | character(len=*), intent(in),optional :: name |
---|
104 | integer, parameter :: INITIAL_ALLOC_SIZE = 10, GROW_FACTOR = 2 |
---|
105 | |
---|
106 | type(t_submessage) :: submessage_in, submessage_out |
---|
107 | type(t_local_submessage) :: submessage_local |
---|
108 | integer :: dim3, dim4 |
---|
109 | integer :: ind, ind_loc, remote_ind_glo, loc_ind_glo, i, remote_rank |
---|
110 | integer :: message_in_size, message_out_size, message_local_size, buffer_in_size, buffer_out_size |
---|
111 | type(t_local_submessage), allocatable :: message_local_tmp(:) |
---|
112 | type(t_submessage), allocatable :: message_in_tmp(:), message_out_tmp(:) |
---|
113 | integer :: field_type |
---|
114 | |
---|
115 | !$omp barrier |
---|
116 | !$omp master |
---|
117 | !init off-device |
---|
118 | message%ondevice=.false. |
---|
119 | message%send_seq = 0 |
---|
120 | message%wait_seq = 0 |
---|
121 | |
---|
122 | if( request(1)%field_type /= field(1)%field_type ) call dynamico_abort( "init_message : field_type/request mismatch" ) |
---|
123 | field_type = request(1)%field_type |
---|
124 | |
---|
125 | ! Set field%rval4d pointer to always use 4d array |
---|
126 | do ind = 1, ndomain |
---|
127 | if( field(ind)%ndim == 2 ) field(ind)%rval4d(1:size(field(ind)%rval2d,1),1:1,1:1) => field(ind)%rval2d |
---|
128 | ! This is Fortran 2008 : can be avoided by using a subroutine with rval3d as a 1D dummy argument |
---|
129 | ! (/!\ : using a subroutine might generate a temporary contiguous array) |
---|
130 | if( field(ind)%ndim == 3 ) field(ind)%rval4d(1:size(field(ind)%rval3d,1), & |
---|
131 | 1:size(field(ind)%rval3d,2), 1:1) => field(ind)%rval3d |
---|
132 | end do |
---|
133 | dim3 = size(field(1)%rval4d,2) |
---|
134 | dim4 = size(field(1)%rval4d,3) |
---|
135 | message%field => field |
---|
136 | message%request => request |
---|
137 | ! Create list of inbound/outbound/local messages |
---|
138 | allocate(message_in_tmp(INITIAL_ALLOC_SIZE)) |
---|
139 | message_in_size=0 |
---|
140 | allocate(message_out_tmp(INITIAL_ALLOC_SIZE)) |
---|
141 | message_out_size=0 |
---|
142 | allocate(message_local_tmp(INITIAL_ALLOC_SIZE)) |
---|
143 | message_local_size=0 |
---|
144 | do loc_ind_glo = 1, ndomain_glo |
---|
145 | do remote_ind_glo = 1, ndomain_glo |
---|
146 | if(domglo_rank(loc_ind_glo) == mpi_rank) then |
---|
147 | ind_loc = domglo_loc_ind(loc_ind_glo) |
---|
148 | if( domglo_rank(remote_ind_glo) == mpi_rank ) then ! If sending to local domain |
---|
149 | if(request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then ! Add only non-empty messages |
---|
150 | ! Add local message ind_loc -> remote_ind_glo, aggregarting submessage_in and submessage_out into submessage_local |
---|
151 | submessage_out = make_submessage( field_type, request(ind_loc)%points_HtoB(remote_ind_glo), & |
---|
152 | ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) |
---|
153 | submessage_in = make_submessage( field_type, request(domglo_loc_ind(remote_ind_glo))%points_BtoH(domloc_glo_ind(ind_loc)), & |
---|
154 | domglo_loc_ind(remote_ind_glo), domloc_glo_ind(ind_loc), dim3, dim4, request(1)%vector) |
---|
155 | submessage_local%src_ind_loc = ind_loc |
---|
156 | submessage_local%dest_ind_loc = domglo_loc_ind(remote_ind_glo) |
---|
157 | submessage_local%npoints = submessage_out%npoints |
---|
158 | submessage_local%displ_src = submessage_out%displs |
---|
159 | submessage_local%displ_dest = submessage_in%displs |
---|
160 | submessage_local%sign = submessage_in%sign |
---|
161 | ! Add to local message list |
---|
162 | call array_append_local_submessage( message_local_tmp, message_local_size, submessage_local) |
---|
163 | endif |
---|
164 | else ! If remote domain |
---|
165 | ! When data to send to remote_domain, add submessage in message%message_out |
---|
166 | if( request(ind_loc)%points_HtoB(remote_ind_glo)%npoints > 0 ) then |
---|
167 | submessage_out = make_submessage( field_type, request(ind_loc)%points_HtoB(remote_ind_glo), & |
---|
168 | ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) |
---|
169 | call array_append_submessage( message_out_tmp, message_out_size, submessage_out ) |
---|
170 | end if |
---|
171 | end if |
---|
172 | end if |
---|
173 | end do |
---|
174 | end do |
---|
175 | ! Recv and Send submessages are transposed to recieve and send in same order |
---|
176 | ! We iterate over global domain index to match sends with recieves (local domains are not ordered like global domains) |
---|
177 | do remote_ind_glo = 1, ndomain_glo |
---|
178 | do loc_ind_glo = 1, ndomain_glo |
---|
179 | if( (domglo_rank(loc_ind_glo) == mpi_rank) .and. (domglo_rank(remote_ind_glo) /= mpi_rank) ) then |
---|
180 | ind_loc = domglo_loc_ind(loc_ind_glo) |
---|
181 | if( request(ind_loc)%points_BtoH(remote_ind_glo)%npoints > 0 ) then |
---|
182 | submessage_in = make_submessage( field_type, request(ind_loc)%points_BtoH(remote_ind_glo), & |
---|
183 | ind_loc, remote_ind_glo, dim3, dim4, request(1)%vector ) |
---|
184 | call array_append_submessage( message_in_tmp, message_in_size, submessage_in ) |
---|
185 | end if |
---|
186 | end if |
---|
187 | end do |
---|
188 | end do |
---|
189 | |
---|
190 | |
---|
191 | ! Trim message_xx_tmp and put it in message%message_xx |
---|
192 | allocate(message%message_in(message_in_size)); message%message_in(:) = message_in_tmp(:message_in_size) |
---|
193 | allocate(message%message_out(message_out_size)); message%message_out(:) = message_out_tmp(:message_out_size) |
---|
194 | allocate(message%message_local(message_local_size)); message%message_local(:) = message_local_tmp(:message_local_size) |
---|
195 | |
---|
196 | ! Allocate MPI buffers |
---|
197 | allocate( message%mpi_buffer_in(0:mpi_size-1) ) |
---|
198 | allocate( message%mpi_buffer_out(0:mpi_size-1) ) |
---|
199 | do i = 0, mpi_size-1 |
---|
200 | buffer_in_size = dim3*dim4*sum( message%message_in(:)%npoints, message%message_in(:)%remote_rank == i ) |
---|
201 | buffer_out_size = dim3*dim4*sum( message%message_out(:)%npoints, message%message_out(:)%remote_rank == i ) |
---|
202 | !TODO : what if size == 0 ? |
---|
203 | allocate( message%mpi_buffer_in(i)%buff( buffer_in_size ) ) |
---|
204 | allocate( message%mpi_buffer_out(i)%buff( buffer_out_size ) ) |
---|
205 | message%mpi_buffer_in(i)%n=0 |
---|
206 | message%mpi_buffer_out(i)%n=0 |
---|
207 | end do |
---|
208 | ! Set offsets in submessages |
---|
209 | do i=1, size(message%message_out) |
---|
210 | remote_rank = message%message_out(i)%remote_rank |
---|
211 | message%message_out(i)%mpi_buffer_displ = message%mpi_buffer_out(remote_rank)%n |
---|
212 | message%mpi_buffer_out(remote_rank)%n = message%mpi_buffer_out(remote_rank)%n + message%message_out(i)%npoints*dim3*dim4 |
---|
213 | end do |
---|
214 | do i=1, size(message%message_in) |
---|
215 | remote_rank = message%message_in(i)%remote_rank |
---|
216 | message%message_in(i)%mpi_buffer_displ = message%mpi_buffer_in(remote_rank)%n |
---|
217 | message%mpi_buffer_in(remote_rank)%n = message%mpi_buffer_in(remote_rank)%n + message%message_in(i)%npoints*dim3*dim4 |
---|
218 | end do |
---|
219 | ! Create persistant MPI requests |
---|
220 | allocate( message%mpi_requests_in(0:mpi_size-1) ) |
---|
221 | allocate( message%mpi_requests_out(0:mpi_size-1) ) |
---|
222 | do i = 0, mpi_size-1 |
---|
223 | if( size(message%mpi_buffer_in(i)%buff) /= message%mpi_buffer_in(i)%n & |
---|
224 | .or. size(message%mpi_buffer_out(i)%buff) /= message%mpi_buffer_out(i)%n)& |
---|
225 | call dynamico_abort("Internal error in transfert_mpi : mpi buffer size different than expected") |
---|
226 | call MPI_Send_Init( message%mpi_buffer_out(i)%buff, message%mpi_buffer_out(i)%n, MPI_REAL8, i,& |
---|
227 | 100, comm_icosa, message%mpi_requests_out(i), ierr ) |
---|
228 | call MPI_Recv_Init( message%mpi_buffer_in(i)%buff, message%mpi_buffer_in(i)%n, MPI_REAL8, i,& |
---|
229 | 100, comm_icosa, message%mpi_requests_in(i), ierr ) |
---|
230 | end do |
---|
231 | !$omp end master |
---|
232 | !$omp barrier |
---|
233 | contains |
---|
234 | ! Generate submessage from points |
---|
235 | function make_submessage(field_type, points, ind_loc, remote_ind_glo, dim3, dim4, vector) result(submessage) |
---|
236 | use dimensions, only : swap_dimensions, iim, u_pos, z_pos |
---|
237 | integer, intent(in) :: field_type |
---|
238 | type(t_points), intent(in) :: points |
---|
239 | integer, intent(in) :: ind_loc, remote_ind_glo, dim3, dim4 |
---|
240 | logical, intent(in) :: vector |
---|
241 | integer :: k |
---|
242 | type(t_submessage) :: submessage |
---|
243 | |
---|
244 | call swap_dimensions(ind_loc) |
---|
245 | submessage%ind_loc = ind_loc |
---|
246 | submessage%remote_ind_glo = remote_ind_glo |
---|
247 | submessage%remote_rank = domglo_rank(remote_ind_glo) |
---|
248 | submessage%npoints = points%npoints |
---|
249 | submessage%mpi_buffer_displ = -1 ! Buffers not allocated yet |
---|
250 | allocate( submessage%displs( points%npoints ) ) |
---|
251 | submessage%displs(:) = points%i + (points%j-1)*iim |
---|
252 | if(field_type == field_U) submessage%displs = submessage%displs + u_pos( points%elt ) |
---|
253 | if(field_type == field_Z) submessage%displs = submessage%displs + z_pos( points%elt ) |
---|
254 | allocate(submessage%sign( points%npoints )) |
---|
255 | if( vector ) then ! For U fields only |
---|
256 | submessage%sign(:) = (/( domain(ind_loc)%edge_assign_sign(points%elt(k)-1, points%i(k), points%j(k)) ,k=1,points%npoints)/) |
---|
257 | else |
---|
258 | submessage%sign(:) = 1 |
---|
259 | endif |
---|
260 | end function |
---|
261 | |
---|
262 | ! Add element to array, and reallocate if necessary |
---|
263 | subroutine array_append_submessage( a, a_size, elt ) |
---|
264 | type(t_submessage), allocatable, intent(inout) :: a(:) |
---|
265 | integer, intent(inout) :: a_size |
---|
266 | type(t_submessage), intent(in) :: elt |
---|
267 | type(t_submessage), allocatable :: a_tmp(:) |
---|
268 | integer, parameter :: GROW_FACTOR = 2 |
---|
269 | |
---|
270 | if( size( a ) <= a_size ) then |
---|
271 | allocate( a_tmp ( a_size * GROW_FACTOR ) ) |
---|
272 | a_tmp(1:a_size) = a(1:a_size) |
---|
273 | call move_alloc(a_tmp, a) |
---|
274 | end if |
---|
275 | a_size = a_size + 1 |
---|
276 | a(a_size) = elt; |
---|
277 | end subroutine |
---|
278 | ! Add element to array, and reallocate if necessary |
---|
279 | subroutine array_append_local_submessage( a, a_size, elt ) |
---|
280 | type(t_local_submessage), allocatable, intent(inout) :: a(:) |
---|
281 | integer, intent(inout) :: a_size |
---|
282 | type(t_local_submessage), intent(in) :: elt |
---|
283 | type(t_local_submessage), allocatable :: a_tmp(:) |
---|
284 | integer, parameter :: GROW_FACTOR = 2 |
---|
285 | |
---|
286 | if( size( a ) <= a_size ) then |
---|
287 | allocate( a_tmp ( a_size * GROW_FACTOR ) ) |
---|
288 | a_tmp(1:a_size) = a(1:a_size) |
---|
289 | call move_alloc(a_tmp, a) |
---|
290 | end if |
---|
291 | a_size = a_size + 1 |
---|
292 | a(a_size) = elt; |
---|
293 | end subroutine |
---|
294 | ! Je demande pardon au dieu du copier-coller car j'ai péché |
---|
295 | end subroutine |
---|
296 | |
---|
297 | subroutine message_create_ondevice(message) |
---|
298 | use mpi_mod |
---|
299 | use mpipara, only : mpi_size, comm_icosa |
---|
300 | type(t_message), intent(inout) :: message |
---|
301 | integer :: i, ierr |
---|
302 | |
---|
303 | if( message%ondevice ) call dynamico_abort("Message already on device") |
---|
304 | |
---|
305 | !$acc enter data copyin(message) async |
---|
306 | !$acc enter data copyin(message%mpi_buffer_in(:)) async |
---|
307 | !$acc enter data copyin(message%mpi_buffer_out(:)) async |
---|
308 | do i = 0, mpi_size-1 |
---|
309 | !$acc enter data copyin(message%mpi_buffer_in(i)%buff(:)) async |
---|
310 | !$acc enter data copyin(message%mpi_buffer_out(i)%buff(:)) async |
---|
311 | end do |
---|
312 | !$acc enter data copyin(message%message_in(:)) async |
---|
313 | do i = 1, size( message%message_in ) |
---|
314 | !$acc enter data copyin(message%message_in(i)%displs(:)) async |
---|
315 | !$acc enter data copyin(message%message_in(i)%sign(:)) async |
---|
316 | end do |
---|
317 | !$acc enter data copyin(message%message_out(:)) async |
---|
318 | do i = 1, size( message%message_out ) |
---|
319 | !$acc enter data copyin(message%message_out(i)%displs(:)) async |
---|
320 | !!$acc enter data copyin(message%message_out(i)%sign(:)) async |
---|
321 | end do |
---|
322 | !$acc enter data copyin(message%message_local(:)) async |
---|
323 | do i = 1, size( message%message_local ) |
---|
324 | !$acc enter data copyin(message%message_local(i)%displ_src(:)) async |
---|
325 | !$acc enter data copyin(message%message_local(i)%displ_dest(:)) async |
---|
326 | !$acc enter data copyin(message%message_local(i)%sign(:)) async |
---|
327 | end do |
---|
328 | !$acc enter data copyin(message%field(:)) async |
---|
329 | do i = 1, ndomain |
---|
330 | !$acc enter data copyin(message%field(i)%rval4d(:,:,:)) async |
---|
331 | end do |
---|
332 | |
---|
333 | !$acc wait |
---|
334 | do i = 0, mpi_size-1 |
---|
335 | call MPI_Request_free(message%mpi_requests_out(i), ierr) |
---|
336 | call MPI_Request_free(message%mpi_requests_in(i), ierr) |
---|
337 | !$acc host_data use_device(message%mpi_buffer_out(i)%buff) |
---|
338 | ! /!\ buff(1) is important for PGI to avoid temporary array copy |
---|
339 | call MPI_Send_Init( message%mpi_buffer_out(i)%buff(1), message%mpi_buffer_out(i)%n, MPI_REAL8, i,& |
---|
340 | 0, comm_icosa, message%mpi_requests_out(i), ierr ) |
---|
341 | !$acc end host_data |
---|
342 | !$acc host_data use_device(message%mpi_buffer_in(i)%buff) |
---|
343 | call MPI_Recv_Init( message%mpi_buffer_in(i)%buff(1), message%mpi_buffer_in(i)%n, MPI_REAL8, i,& |
---|
344 | 0, comm_icosa, message%mpi_requests_in(i), ierr ) |
---|
345 | !$acc end host_data |
---|
346 | end do |
---|
347 | |
---|
348 | message%ondevice=.true. |
---|
349 | !!$acc update device(message%ondevice) |
---|
350 | end subroutine |
---|
351 | |
---|
352 | subroutine message_delete_ondevice(message) |
---|
353 | use mpipara, only : mpi_size |
---|
354 | type(t_message), intent(inout) :: message |
---|
355 | integer :: i |
---|
356 | |
---|
357 | if( .not. message%ondevice ) call dynamico_abort("Message not on device") |
---|
358 | |
---|
359 | do i = 1, size( message%message_in ) |
---|
360 | !$acc exit data delete(message%message_in(i)%displs(:)) async |
---|
361 | !$acc exit data delete(message%message_in(i)%sign(:)) async |
---|
362 | end do |
---|
363 | !$acc exit data delete(message%message_in(:)) async |
---|
364 | do i = 1, size( message%message_out ) |
---|
365 | !$acc exit data delete(message%message_out(i)%displs(:)) async |
---|
366 | !!$acc exit data delete(message%message_out(i)%sign(:)) async |
---|
367 | end do |
---|
368 | !$acc exit data delete(message%message_out(:)) async |
---|
369 | do i = 1, size( message%message_local ) |
---|
370 | !$acc exit data delete(message%message_local(i)%displ_src(:)) async |
---|
371 | !$acc exit data delete(message%message_local(i)%displ_dest(:)) async |
---|
372 | !$acc exit data delete(message%message_local(i)%sign(:)) async |
---|
373 | end do |
---|
374 | !$acc exit data delete(message%message_local(:)) async |
---|
375 | do i = 0, mpi_size-1 |
---|
376 | !$acc exit data delete(message%mpi_buffer_in(i)%buff(:)) async |
---|
377 | !$acc exit data delete(message%mpi_buffer_out(i)%buff(:)) async |
---|
378 | end do |
---|
379 | !$acc exit data delete(message%mpi_buffer_in(:)) async |
---|
380 | !$acc exit data delete(message%mpi_buffer_out(:)) async |
---|
381 | do i = 1, ndomain |
---|
382 | !$acc exit data delete(message%field(i)%rval4d(:,:,:)) async |
---|
383 | end do |
---|
384 | !$acc exit data delete(message%field(:)) async |
---|
385 | !$acc exit data delete(message) async |
---|
386 | message%ondevice=.false. |
---|
387 | end subroutine |
---|
388 | |
---|
389 | subroutine finalize_message(message) |
---|
390 | use mpipara, only : mpi_size |
---|
391 | type(t_message), intent(inout) :: message |
---|
392 | integer :: i, ierr |
---|
393 | |
---|
394 | !$omp barrier |
---|
395 | !$omp master |
---|
396 | if(message%send_seq /= message%wait_seq) call dynamico_abort("No matching wait_message before finalization") |
---|
397 | |
---|
398 | if(message%ondevice) call message_delete_ondevice(message) |
---|
399 | deallocate(message%message_in) |
---|
400 | deallocate(message%message_out) |
---|
401 | deallocate(message%message_local) |
---|
402 | do i=0, mpi_size-1 |
---|
403 | call MPI_Request_free(message%mpi_requests_in(i), ierr) |
---|
404 | call MPI_Request_free(message%mpi_requests_out(i), ierr) |
---|
405 | deallocate(message%mpi_buffer_in(i)%buff) |
---|
406 | deallocate(message%mpi_buffer_out(i)%buff) |
---|
407 | end do |
---|
408 | deallocate(message%mpi_buffer_in) |
---|
409 | deallocate(message%mpi_buffer_out) |
---|
410 | deallocate(message%mpi_requests_in) |
---|
411 | deallocate(message%mpi_requests_out) |
---|
412 | !$omp end master |
---|
413 | !$omp barrier |
---|
414 | end subroutine |
---|
415 | |
---|
416 | subroutine send_message(field, message) |
---|
417 | use mpi_mod |
---|
418 | use domain_mod, only : assigned_domain |
---|
419 | use omp_para, only : distrib_level |
---|
420 | type(t_field),pointer :: field(:) |
---|
421 | type(t_message), target :: message |
---|
422 | integer :: i, k, d3, d4, local_displ |
---|
423 | integer :: ierr, d3_begin, d3_end, dim4, dim3 |
---|
424 | |
---|
425 | call enter_profile(profile_mpi) |
---|
426 | |
---|
427 | ! Needed because rval4d is set in init_message |
---|
428 | if( .not. associated( message%field, field ) ) & |
---|
429 | call dynamico_abort("send_message must be called with the same field used in init_message") |
---|
430 | |
---|
431 | !Prepare 'message' for on-device copies if field is on device |
---|
432 | !$omp master |
---|
433 | if( field(1)%ondevice .and. .not. message%ondevice ) call message_create_ondevice(message) |
---|
434 | if( field(1)%ondevice .neqv. message%ondevice ) call dynamico_abort("send_message : internal device/host memory synchronization error") |
---|
435 | ! Check if previous message has been waited |
---|
436 | if(message%send_seq /= message%wait_seq) & |
---|
437 | call dynamico_abort("No matching wait_message before new send_message") |
---|
438 | message%send_seq = message%send_seq + 1 |
---|
439 | !$omp end master |
---|
440 | |
---|
441 | call enter_profile(profile_mpi_barrier) |
---|
442 | !$omp barrier |
---|
443 | call exit_profile(profile_mpi_barrier) |
---|
444 | |
---|
445 | dim4 = size(message%field(1)%rval4d, 3) |
---|
446 | dim3 = size(message%field(1)%rval4d, 2) |
---|
447 | CALL distrib_level( 1, dim3, d3_begin, d3_end ) |
---|
448 | |
---|
449 | call enter_profile(profile_mpi_copies) |
---|
450 | !$acc data present(message) async if(message%ondevice) |
---|
451 | |
---|
452 | ! Halo to Buffer : copy outbound message to MPI buffers |
---|
453 | !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) |
---|
454 | do i = 1, size( message%message_out ) |
---|
455 | if( assigned_domain( message%message_out(i)%ind_loc ) ) then |
---|
456 | !$acc loop collapse(2) |
---|
457 | do d4 = 1, dim4 |
---|
458 | do d3 = d3_begin, d3_end |
---|
459 | local_displ = message%message_out(i)%mpi_buffer_displ + message%message_out(i)%npoints*( (d3-1) + dim3*(d4-1) ) |
---|
460 | !$acc loop |
---|
461 | do k = 1, message%message_out(i)%npoints |
---|
462 | !print *, "buff", message%message_out(i)%remote_rank, k+local_displ, "<- field", message%message_out(i)%ind_loc, message%message_out(i)%displs(k), d3, d4, message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4) |
---|
463 | message%mpi_buffer_out(message%message_out(i)%remote_rank)%buff(k+local_displ) = message%field(message%message_out(i)%ind_loc)%rval4d(message%message_out(i)%displs(k),d3, d4) |
---|
464 | end do |
---|
465 | end do |
---|
466 | end do |
---|
467 | endif |
---|
468 | end do |
---|
469 | |
---|
470 | ! Halo to Halo : copy local messages from source field to destination field |
---|
471 | !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) |
---|
472 | do i = 1, size( message%message_local ) |
---|
473 | if( assigned_domain( message%message_local(i)%dest_ind_loc ) ) then |
---|
474 | !$acc loop collapse(2) |
---|
475 | do d4 = 1, dim4 |
---|
476 | do d3 = d3_begin, d3_end |
---|
477 | ! Cannot collapse because size(displ_dest) varies with i |
---|
478 | !$acc loop vector |
---|
479 | do k = 1, message%message_local(i)%npoints |
---|
480 | message%field(message%message_local(i)%dest_ind_loc)%rval4d(message%message_local(i)%displ_dest(k),d3,d4) = & |
---|
481 | message%message_local(i)%sign(k)*message%field(message%message_local(i)%src_ind_loc)%rval4d(message%message_local(i)%displ_src(k),d3,d4) |
---|
482 | end do |
---|
483 | end do |
---|
484 | end do |
---|
485 | endif |
---|
486 | end do |
---|
487 | |
---|
488 | !$acc end data |
---|
489 | call exit_profile(profile_mpi_copies) |
---|
490 | |
---|
491 | |
---|
492 | call enter_profile(profile_mpi_barrier) |
---|
493 | !$acc wait |
---|
494 | !$omp barrier |
---|
495 | call exit_profile(profile_mpi_barrier) |
---|
496 | |
---|
497 | !$omp master |
---|
498 | call MPI_Startall( size(message%mpi_requests_out), message%mpi_requests_out, ierr ) |
---|
499 | call MPI_Startall( size(message%mpi_requests_in), message%mpi_requests_in, ierr ) |
---|
500 | !$omp end master |
---|
501 | |
---|
502 | call exit_profile(profile_mpi) |
---|
503 | end subroutine |
---|
504 | |
---|
505 | subroutine test_message(message) |
---|
506 | use mpi_mod |
---|
507 | type(t_message) :: message |
---|
508 | integer :: ierr |
---|
509 | logical :: completed |
---|
510 | |
---|
511 | !$omp master |
---|
512 | call MPI_Testall( size(message%mpi_requests_out), message%mpi_requests_out, completed, MPI_STATUSES_IGNORE, ierr ) |
---|
513 | call MPI_Testall( size(message%mpi_requests_in), message%mpi_requests_in, completed, MPI_STATUSES_IGNORE, ierr ) |
---|
514 | !$omp end master |
---|
515 | end subroutine |
---|
516 | |
---|
517 | subroutine wait_message(message) |
---|
518 | use mpi_mod |
---|
519 | use domain_mod, only : assigned_domain |
---|
520 | use omp_para, only : distrib_level |
---|
521 | type(t_message), target :: message |
---|
522 | integer :: d3_begin, d3_end, dim4, dim3, dim12 |
---|
523 | integer :: i, ierr, k, d3, d4, local_displ |
---|
524 | |
---|
525 | ! Check if message has been sent and not recieved yet |
---|
526 | ! note : barrier needed between this and send_seq increment, and this and wait_seq increment |
---|
527 | ! note : watch out for integer overflow a = b+1 doesn't imply a>b |
---|
528 | if(message%send_seq /= message%wait_seq+1) then |
---|
529 | print*, "WARNING : wait_message called multiple times for one send_message, skipping" |
---|
530 | return ! Don't recieve message if already recieved |
---|
531 | end if |
---|
532 | |
---|
533 | call enter_profile(profile_mpi) |
---|
534 | |
---|
535 | dim4 = size(message%field(1)%rval4d, 3) |
---|
536 | dim3 = size(message%field(1)%rval4d, 2) |
---|
537 | dim12 = size(message%field(1)%rval4d, 1) |
---|
538 | CALL distrib_level( 1, dim3, d3_begin, d3_end ) |
---|
539 | |
---|
540 | call enter_profile(profile_mpi_waitall) |
---|
541 | !$omp master |
---|
542 | call MPI_Waitall( size(message%mpi_requests_out), message%mpi_requests_out, MPI_STATUSES_IGNORE, ierr ) |
---|
543 | call MPI_Waitall( size(message%mpi_requests_in), message%mpi_requests_in, MPI_STATUSES_IGNORE, ierr ) |
---|
544 | !$omp end master |
---|
545 | call exit_profile(profile_mpi_waitall) |
---|
546 | |
---|
547 | call enter_profile(profile_mpi_barrier) |
---|
548 | !$omp barrier |
---|
549 | call exit_profile(profile_mpi_barrier) |
---|
550 | |
---|
551 | call enter_profile(profile_mpi_copies) |
---|
552 | !$acc data present(message) async if(message%ondevice) |
---|
553 | |
---|
554 | dim4 = size(message%field(1)%rval4d, 3) |
---|
555 | ! Buffer to Halo : copy inbound message to field |
---|
556 | !$acc parallel loop default(none) present(message, assigned_domain) async if(message%ondevice) |
---|
557 | do i = 1, size( message%message_in ) |
---|
558 | if( assigned_domain( message%message_in(i)%ind_loc ) ) then |
---|
559 | !$acc loop collapse(2) |
---|
560 | do d4 = 1, dim4 |
---|
561 | do d3 = d3_begin, d3_end |
---|
562 | local_displ = message%message_in(i)%mpi_buffer_displ + message%message_in(i)%npoints*( (d3-1) + dim3*(d4-1) ) |
---|
563 | !$acc loop |
---|
564 | do k = 1, message%message_in(i)%npoints |
---|
565 | !print *, "field", message%message_in(i)%ind_loc, message%message_in(i)%displs(k), d3, d4, "-> buff", message%message_in(i)%remote_rank, k+local_displ, message%mpi_buffer_in(message%message_in(i)%remote_rank)%buff(k+local_displ) |
---|
566 | message%field(message%message_in(i)%ind_loc)%rval4d(message%message_in(i)%displs(k),d3,d4) & |
---|
567 | = message%mpi_buffer_in(message%message_in(i)%remote_rank)%buff(k+local_displ) |
---|
568 | end do |
---|
569 | end do |
---|
570 | end do |
---|
571 | endif |
---|
572 | end do |
---|
573 | |
---|
574 | !$acc end data |
---|
575 | call exit_profile(profile_mpi_copies) |
---|
576 | |
---|
577 | !$omp master |
---|
578 | message%wait_seq = message%wait_seq + 1 |
---|
579 | !$omp end master |
---|
580 | |
---|
581 | call enter_profile(profile_mpi_barrier) |
---|
582 | !$omp barrier |
---|
583 | call exit_profile(profile_mpi_barrier) |
---|
584 | call exit_profile(profile_mpi) |
---|
585 | end subroutine |
---|
586 | end module |
---|