MFC
Exascale flow solver
Loading...
Searching...
No Matches
m_mpi_common.fpp.f90
Go to the documentation of this file.
1# 1 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2!>
3!! @file
4!! @brief Contains module m_mpi_common
5
6# 1 "/home/runner/work/MFC/MFC/src/common/include/case.fpp" 1
7! This file exists so that Fypp can be run without generating case.fpp files for
8! each target. This is useful when generating documentation, for example. This
9! should also let MFC be built with CMake directly, without invoking mfc.sh.
10
11! For pre-process.
12# 8 "/home/runner/work/MFC/MFC/src/common/include/case.fpp"
13
14! For moving immersed boundaries in simulation
15# 12 "/home/runner/work/MFC/MFC/src/common/include/case.fpp"
16# 6 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp" 2
17# 1 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 1
18# 1 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 1
19# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
20# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
21# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
22# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
23# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
24# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
25
26# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
27# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
28# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
29
30# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
31# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
32! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
33! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
34# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
35# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
36# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
37
38# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
39# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
40
41# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
42
43# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
44
45# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
46
47# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
48
49# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
50
51# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
52
53# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
54
55# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
56! New line at end of file is required for FYPP
57# 2 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
58# 1 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 1
59# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
60# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
61# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
62# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
63# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
64# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
65
66# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
67# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
68# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
69
70# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
71# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
72! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
73! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
74# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
75# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
76# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
77
78# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
79# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
80
81# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
82
83# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
84
85# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
86
87# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
88
89# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
90
91# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
92
93# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
94
95# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
96! New line at end of file is required for FYPP
97# 2 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 2
98
99# 4 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
100# 5 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
101# 6 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
102# 7 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
103# 8 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
104
105# 20 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
106
107# 43 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
108
109# 48 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
110
111# 53 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
112
113# 58 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
114
115# 63 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
116
117# 68 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
118
119# 81 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
120
121# 95 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
122
123# 100 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
124
125# 105 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
126
127# 110 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
128
129# 115 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
130
131# 120 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
132
133# 125 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
134
135# 130 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
136
137# 135 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
138
139# 165 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
140
141# 219 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
142
143# 233 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
144
145# 258 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
146
147# 269 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
148
149# 271 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
150# 282 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
151
152# 332 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
153
154# 342 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
155
156# 352 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
157
158# 361 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
159
160# 378 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
161
162# 388 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
163
164# 395 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
165
166# 401 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
167
168# 407 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
169
170# 413 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
171
172# 419 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
173
174# 425 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
175! New line at end of file is required for FYPP
176# 3 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
177# 1 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 1
178# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
179# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
180# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
181# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
182# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
183# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
184
185# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
186# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
187# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
188
189# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
190# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
191! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
192! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
193# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
194# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
195# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
196
197# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
198# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
199
200# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
201
202# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
203
204# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
205
206# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
207
208# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
209
210# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
211
212# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
213
214# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
215! New line at end of file is required for FYPP
216# 2 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 2
217
218# 7 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
219
220# 17 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
221
222# 22 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
223
224# 27 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
225
226# 32 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
227
228# 37 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
229
230# 42 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
231
232# 47 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
233
234# 52 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
235
236# 57 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
237
238# 62 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
239
240# 73 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
241
242# 78 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
243
244# 83 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
245
246# 88 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
247
248# 103 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
249
250# 131 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
251
252# 160 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
253
254# 175 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
255
256# 193 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
257
258# 215 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
259
260# 244 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
261
262# 259 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
263
264# 269 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
265
266# 278 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
267
268# 294 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
269
270# 304 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
271
272# 311 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
273! New line at end of file is required for FYPP
274# 4 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
275
276! GPU parallel region (scalar reductions, maxval/minval)
277# 23 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
278
279! GPU parallel loop over threads (most common GPU macro)
280# 43 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
281
282! Required closing for GPU_PARALLEL_LOOP
283# 55 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
284
285! Mark routine for device compilation
286# 112 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
287
288! Declare device-resident data
289# 130 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
290
291! Inner loop within a GPU parallel region
292# 145 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
293
294! Scoped GPU data region
295# 164 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
296
297! Host code with device pointers (for MPI with GPU buffers)
298# 193 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
299
300! Allocate device memory (unscoped)
301# 207 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
302
303! Free device memory
304# 219 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
305
306! Atomic operation on device
307# 231 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
308
309! End atomic capture block
310# 242 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
311
312! Copy data between host and device
313# 254 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
314
315! Synchronization barrier
316# 266 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
317
318! Import GPU library module (openacc or omp_lib)
319# 275 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
320
321! Emit code only for AMD compiler
322# 282 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
323
324! Emit code for non-Cray compilers
325# 289 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
326
327! Emit code only for Cray compiler
328# 296 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
329
330! Emit code for non-NVIDIA compilers
331# 303 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
332
333# 305 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
334# 306 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
335! New line at end of file is required for FYPP
336# 2 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 2
337
338# 14 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
339
340! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI
341! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an
342! example see misc/nvidia_uvm/bind.sh.
343# 52 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
344
345! Allocate and create GPU device memory
346# 72 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
347
348! Free GPU device memory and deallocate
349# 80 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
350
351! Cray-specific GPU pointer setup for vector fields
352# 104 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
353
354! Cray-specific GPU pointer setup for scalar fields
355# 120 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
356
357! Cray-specific GPU pointer setup for acoustic source spatials
358# 145 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
359
360# 151 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
361
362# 158 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
363! New line at end of file is required for FYPP
364# 7 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp" 2
365
366!> @brief MPI communication layer: domain decomposition, halo exchange, reductions, and parallel I/O setup
367module m_mpi_common
368
369#ifdef MFC_MPI
370 use mpi !< message passing interface (mpi) module
371#endif
372
373 use m_derived_types
374 use m_global_parameters
375 use m_helper
376 use ieee_arithmetic
377 use m_nvtx
378 use m_constants, only: recon_type_weno
379
380 implicit none
381
382 private :: s_apply_decomposition_policies
383
384 integer, private :: v_size
385
386# 27 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
387#if defined(MFC_OpenACC)
388# 27 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
389!$acc declare create(v_size)
390# 27 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
391#elif defined(MFC_OpenMP)
392# 27 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
393!$omp declare target (v_size)
394# 27 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
395#endif
396# 28 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
397
398 real(wp), private, allocatable, dimension(:) :: buff_send !< Primitive variable send buffer for halo exchange
399 !> Primitive variable receive buffer for halo exchange Variables for EL bubbles communication
400 real(wp), private, allocatable, dimension(:) :: buff_recv
401 type(int_bounds_info) :: comm_coords(3)
402 integer :: comm_size(3)
403 !> q_beta indices to communicate: 1=void fraction, 2=d(beta)/dt, 5=energy source
404 integer :: beta_vars(1:3) = [1, 2, 5]
405
406# 36 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
407#if defined(MFC_OpenACC)
408# 36 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
409!$acc declare create(comm_coords, comm_size, beta_vars)
410# 36 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
411#elif defined(MFC_OpenMP)
412# 36 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
413!$omp declare target (comm_coords, comm_size, beta_vars)
414# 36 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
415#endif
416# 37 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
417
418#ifndef __NVCOMPILER_GPU_UNIFIED_MEM
419
420# 39 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
421#if defined(MFC_OpenACC)
422# 39 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
423!$acc declare create(buff_send, buff_recv)
424# 39 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
425#elif defined(MFC_OpenMP)
426# 39 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
427!$omp declare target (buff_send, buff_recv)
428# 39 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
429#endif
430# 40 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
431#endif
432
433 integer(kind=8) :: halo_size
434
435# 43 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
436#if defined(MFC_OpenACC)
437# 43 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
438!$acc declare create(halo_size)
439# 43 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
440#elif defined(MFC_OpenMP)
441# 43 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
442!$omp declare target (halo_size)
443# 43 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
444#endif
445# 44 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
446
447 logical, private :: exchange_all_chemistry_temperatures = .false.
448 logical, private :: use_rdma_transport = .false.
449
450contains
451
452 !> Initialize the module.
453 impure subroutine s_initialize_mpi_common_module(exchange_all_chemistry_temperatures_in, use_rdma_transport_in)
454
455 logical, intent(in) :: exchange_all_chemistry_temperatures_in
456 logical, intent(in) :: use_rdma_transport_in
457
458 exchange_all_chemistry_temperatures = exchange_all_chemistry_temperatures_in
459 use_rdma_transport = use_rdma_transport_in
460
461#ifdef MFC_MPI
462 ! Allocating buff_send/recv and. Please note that for the sake of simplicity, both variables are provided sufficient storage
463 ! to hold the largest buffer in the computational domain.
464
465 if (qbmm .and. .not. polytropic) then
466 v_size = sys_size + 2*nb*nnode
467 else if (heat_conduction .or. (chemistry .and. (chem_params%diffusion .or. exchange_all_chemistry_temperatures))) then
468 v_size = sys_size + 1
469 else
470 v_size = sys_size
471 end if
472
473 if (n > 0) then
474 if (p > 0) then
475 halo_size = nint(-1._wp + 1._wp*buff_size*(v_size)*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)*(p + 2*buff_size &
476 & + 1)/(cells_bounds%mnp_min + 2*buff_size + 1))
477 else
478 halo_size = -1 + buff_size*(v_size)*(cells_bounds%mn_max + 2*buff_size + 1)
479 end if
480 else
481 halo_size = -1 + buff_size*(v_size)
482 end if
483
484
485# 82 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
486#if defined(MFC_OpenACC)
487# 82 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
488!$acc update device(halo_size, v_size)
489# 82 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
490#elif defined(MFC_OpenMP)
491# 82 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
492!$omp target update to(halo_size, v_size)
493# 82 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
494#endif
495# 83 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
496
497#ifndef __NVCOMPILER_GPU_UNIFIED_MEM
498#ifdef MFC_DEBUG
499# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
500 block
501# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
502 use iso_fortran_env, only: output_unit
503# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
504
505# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
506 print *, 'm_mpi_common.fpp:85: ', '@:ALLOCATE(buff_send(0:halo_size), buff_recv(0:halo_size))'
507# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
508
509# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
510 call flush (output_unit)
511# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
512 end block
513# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
514#endif
515# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
516 allocate (buff_send(0:halo_size), buff_recv(0:halo_size))
517# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
518
519# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
520
521# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
522
523# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
524#if defined(MFC_OpenACC)
525# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
526!$acc enter data create(buff_send, buff_recv)
527# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
528#elif defined(MFC_OpenMP)
529# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
530!$omp target enter data map(always,alloc:buff_send, buff_recv)
531# 85 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
532#endif
533# 86 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
534#else
535 allocate (buff_send(0:halo_size), buff_recv(0:halo_size))
536
537# 88 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
538#if defined(MFC_OpenACC)
539# 88 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
540!$acc enter data create(capture:buff_send)
541# 88 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
542#elif defined(MFC_OpenMP)
543# 88 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
544!$omp target enter data map(always,alloc:capture:buff_send)
545# 88 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
546#endif
547# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
548
549# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
550#if defined(MFC_OpenACC)
551# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
552!$acc enter data create(capture:buff_recv)
553# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
554#elif defined(MFC_OpenMP)
555# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
556!$omp target enter data map(always,alloc:capture:buff_recv)
557# 89 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
558#endif
559# 90 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
560#endif
561#endif
562
563
564# 93 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
565#if defined(MFC_OpenACC)
566# 93 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
567!$acc update device(beta_vars)
568# 93 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
569#elif defined(MFC_OpenMP)
570# 93 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
571!$omp target update to(beta_vars)
572# 93 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
573#endif
574# 94 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
575
576 end subroutine s_initialize_mpi_common_module
577
578 !> Initialize the MPI execution environment and query the number of processors and local rank.
579 impure subroutine s_mpi_initialize
580
581#ifdef MFC_MPI
582 integer :: ierr !< Generic flag used to identify and report MPI errors
583
584 call mpi_init(ierr)
585
586 if (ierr /= mpi_success) then
587 print '(A)', 'Unable to initialize MPI environment. Exiting.'
588 call mpi_abort(mpi_comm_world, 1, ierr)
589 end if
590
591 call mpi_comm_size(mpi_comm_world, num_procs, ierr)
592
593 call mpi_comm_rank(mpi_comm_world, proc_rank, ierr)
594#else
595 num_procs = 1
596 proc_rank = 0
597#endif
598
599
600# 118 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
601#if defined(MFC_OpenACC)
602# 118 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
603!$acc update device(num_procs, proc_rank)
604# 118 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
605#elif defined(MFC_OpenMP)
606# 118 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
607!$omp target update to(num_procs, proc_rank)
608# 118 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
609#endif
610# 119 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
611
612 end subroutine s_mpi_initialize
613
614 !> Set up MPI I/O data views and variable pointers for parallel file output.
615 impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, ib_mpi_data, beta, qbmm_pb, qbmm_mv)
616
617 type(scalar_field), dimension(sys_size), intent(in) :: q_cons_vf
618 type(integer_field), optional, intent(in) :: ib_markers
619 type(mpi_io_ib_var), optional, intent(inout) :: ib_mpi_data
620 type(scalar_field), intent(in), optional :: beta
621 type(pres_field), intent(in), optional :: qbmm_pb, qbmm_mv
622 integer, dimension(num_dims) :: sizes_glb, sizes_loc
623
624#ifdef MFC_MPI
625 integer :: i, j
626 integer :: ierr !< Generic flag used to identify and report MPI errors
627 integer :: alt_sys
628 logical :: bind_qbmm_fields
629
630 if (present(qbmm_pb) .neqv. present(qbmm_mv)) then
631 call s_mpi_abort('QBMM MPI I/O requires both pressure and moment fields.')
632 end if
633 bind_qbmm_fields = qbmm .and. .not. polytropic .and. present(qbmm_pb) .and. present(qbmm_mv)
634
635 if (present(beta)) then
636 alt_sys = sys_size + 1
637 else
638 alt_sys = sys_size
639 end if
640
641 do i = 1, sys_size
642 mpi_io_data%var(i)%sf => q_cons_vf(i)%sf(0:m,0:n,0:p)
643 end do
644
645 if (present(beta)) then
646 mpi_io_data%var(alt_sys)%sf => beta%sf(0:m,0:n,0:p)
647 end if
648
649 ! Additional variables pb and mv for non-polytropic qbmm
650 if (bind_qbmm_fields) then
651 do i = 1, nb
652 do j = 1, nnode
653 mpi_io_data%var(sys_size + (i - 1)*nnode + j)%sf => qbmm_pb%sf(0:m,0:n,0:p,j, i)
654 mpi_io_data%var(sys_size + (i - 1)*nnode + j + nb*nnode)%sf => qbmm_mv%sf(0:m,0:n,0:p,j, i)
655 end do
656 end do
657 end if
658
659 ! Define global(g) and local(l) sizes for flow variables
660 sizes_glb(1) = m_glb + 1; sizes_loc(1) = m + 1
661 if (n > 0) then
662 sizes_glb(2) = n_glb + 1; sizes_loc(2) = n + 1
663 if (p > 0) then
664 sizes_glb(num_dims) = p_glb + 1; sizes_loc(num_dims) = p + 1
665 end if
666 end if
667
668 ! Define the view for each variable
669 do i = 1, alt_sys
670 call mpi_type_create_subarray(num_dims, sizes_glb, sizes_loc, start_idx, mpi_order_fortran, mpi_p, &
671 & mpi_io_data%view(i), ierr)
672 call mpi_type_commit(mpi_io_data%view(i), ierr)
673 end do
674
675 if (bind_qbmm_fields) then
676 do i = sys_size + 1, sys_size + 2*nb*nnode
677 call mpi_type_create_subarray(num_dims, sizes_glb, sizes_loc, start_idx, mpi_order_fortran, mpi_p, &
678 & mpi_io_data%view(i), ierr)
679 call mpi_type_commit(mpi_io_data%view(i), ierr)
680 end do
681 end if
682
683 if (present(ib_markers) .neqv. present(ib_mpi_data)) then
684 call s_mpi_abort('Immersed-boundary MPI I/O requires both marker and descriptor fields.')
685 end if
686
687 if (present(ib_markers)) then
688 ib_mpi_data%var%sf => ib_markers%sf(0:m,0:n,0:p)
689 call mpi_type_create_subarray(num_dims, sizes_glb, sizes_loc, start_idx, mpi_order_fortran, mpi_integer, &
690 & ib_mpi_data%view, ierr)
691 call mpi_type_commit(ib_mpi_data%view, ierr)
692 end if
693#endif
694
695 end subroutine s_initialize_mpi_data
696
697 !> Set up MPI I/O data views for downsampled (coarsened) parallel file output.
698 subroutine s_initialize_mpi_data_ds(m_ds, n_ds, p_ds, q_cons_vf)
699
700 integer, intent(in) :: m_ds, n_ds, p_ds
701 type(scalar_field), dimension(sys_size), intent(in), optional :: q_cons_vf
702 integer, dimension(num_dims) :: sizes_loc
703 integer, dimension(3) :: sf_start_idx
704
705#ifdef MFC_MPI
706 integer :: i, ierr
707
708 sf_start_idx = (/0, 0, 0/)
709
710 if (present(q_cons_vf)) then
711 do i = 1, sys_size
712 mpi_io_data%var(i)%sf => q_cons_vf(i)%sf(-1:m_ds + 1,-1:n_ds + 1,-1:p_ds + 1)
713 end do
714 end if
715 ! Define global(g) and local(l) sizes for flow variables
716 sizes_loc(1) = m_ds + 3
717 if (n > 0) then
718 sizes_loc(2) = n_ds + 3
719 if (p > 0) then
720 sizes_loc(num_dims) = p_ds + 3
721 end if
722 end if
723
724 ! Define the view for each variable
725 do i = 1, sys_size
726 call mpi_type_create_subarray(num_dims, sizes_loc, sizes_loc, sf_start_idx, mpi_order_fortran, mpi_p, &
727 & mpi_io_data%view(i), ierr)
728 call mpi_type_commit(mpi_io_data%view(i), ierr)
729 end do
730#endif
731
732 end subroutine s_initialize_mpi_data_ds
733
734 !> Gather variable-length real vectors from all MPI ranks onto the root process.
735 impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root)
736
737 integer, intent(in) :: counts !< Array of vector lengths for each process
738 real(wp), intent(in), dimension(counts) :: my_vector !< Input vector on each process
739 integer, intent(in) :: root !< Rank of the root process
740 real(wp), allocatable, intent(out) :: gathered_vector(:) !< Gathered vector on the root process
741 integer :: i
742 integer :: ierr !< Generic flag used to identify and report MPI errors
743 integer, allocatable :: recounts(:), displs(:)
744
745#ifdef MFC_MPI
746 allocate (recounts(num_procs))
747
748 call mpi_gather(counts, 1, mpi_integer, recounts, 1, mpi_integer, root, mpi_comm_world, ierr)
749
750 allocate (displs(size(recounts)))
751
752 displs(1) = 0
753
754 do i = 2, size(recounts)
755 displs(i) = displs(i - 1) + recounts(i - 1)
756 end do
757
758 allocate (gathered_vector(sum(recounts)))
759 call mpi_gatherv(my_vector, counts, mpi_p, gathered_vector, recounts, displs, mpi_p, root, mpi_comm_world, ierr)
760#endif
761
762 end subroutine s_mpi_gather_data
763
764 !> Gather per-rank time step wall-clock times onto rank 0 for performance reporting.
765 impure subroutine mpi_bcast_time_step_values(proc_time, time_avg)
766
767 real(wp), dimension(0:num_procs - 1), intent(inout) :: proc_time
768 real(wp), intent(inout) :: time_avg
769
770#ifdef MFC_MPI
771 integer :: ierr !< Generic flag used to identify and report MPI errors
772
773 call mpi_gather(time_avg, 1, mpi_p, proc_time(0), 1, mpi_p, 0, mpi_comm_world, ierr)
774#endif
775
776 end subroutine mpi_bcast_time_step_values
777
778 !> Print a case file error with the prohibited condition and message, then abort execution.
779 impure subroutine s_prohibit_abort(condition, message)
780
781 character(len=*), intent(in) :: condition, message
782
783 print *, ""
784 print *, "CASE FILE ERROR"
785 print *, " - Prohibited condition: ", trim(condition)
786 if (len_trim(message) > 0) then
787 print *, " - Note: ", trim(message)
788 end if
789 print *, ""
790 call s_mpi_abort(code=case_file_error_code)
791
792 end subroutine s_prohibit_abort
793
794 !> The goal of this subroutine is to determine the global extrema of the stability criteria in the computational domain. This is
795 !! performed by sifting through the local extrema of each stability criterion. Note that each of the local extrema is from a
796 !! single process, within its assigned section of the computational domain. Finally, note that the global extrema values are
797 !! only bookkept on the rank 0 processor. `max_loc`/`max_glb` hold the max-reduced criteria (ICFL, VCFL, CCFL, TCFL) and
798 !! `min_loc`/`min_glb` hold the min-reduced criteria (Rc).
799 impure subroutine s_mpi_reduce_stability_criteria_extrema(max_loc, min_loc, bubs_loc, max_glb, min_glb, bubs_glb)
800
801 real(wp), dimension(:), intent(in) :: max_loc
802 real(wp), dimension(:), intent(in) :: min_loc
803 integer, intent(in) :: bubs_loc
804 real(wp), dimension(:), intent(out) :: max_glb
805 real(wp), dimension(:), intent(out) :: min_glb
806 integer, intent(out) :: bubs_glb
807
808 max_glb = max_loc
809 min_glb = min_loc
810
811#ifdef MFC_MPI
812 block
813 integer :: ierr
814
815 bubs_glb = 0
816 call mpi_reduce(max_loc(1), max_glb(1), 1, mpi_p, mpi_max, 0, mpi_comm_world, ierr) ! ICFL
817
818 if (viscous) then
819 call mpi_reduce(max_loc(2), max_glb(2), 1, mpi_p, mpi_max, 0, mpi_comm_world, ierr) ! VCFL
820 call mpi_reduce(min_loc(1), min_glb(1), 1, mpi_p, mpi_min, 0, mpi_comm_world, ierr) ! Rc
821 end if
822
823 if (surface_tension) then
824 call mpi_reduce(max_loc(3), max_glb(3), 1, mpi_p, mpi_max, 0, mpi_comm_world, ierr) ! CCFL
825 end if
826
827 if (heat_conduction) then
828 call mpi_reduce(max_loc(4), max_glb(4), 1, mpi_p, mpi_max, 0, mpi_comm_world, ierr) ! TCFL
829 end if
830
831 if (bubbles_lagrange) then
832 call mpi_reduce(bubs_loc, bubs_glb, 1, mpi_integer, mpi_sum, 0, mpi_comm_world, ierr)
833 end if
834 end block
835#else
836 bubs_glb = 0
837 if (bubbles_lagrange) bubs_glb = bubs_loc
838#endif
839
840 end subroutine s_mpi_reduce_stability_criteria_extrema
841
842 !> Reduce a local integer value to its global sum across all MPI ranks.
843 subroutine s_mpi_reduce_int_sum(var_loc, sum)
844
845 integer, intent(in) :: var_loc
846 integer, intent(out) :: sum
847
848#ifdef MFC_MPI
849 integer :: ierr !< Generic flag used to identify and report MPI errors
850
851 call mpi_reduce(var_loc, sum, 1, mpi_integer, mpi_sum, 0, mpi_comm_world, ierr)
852#else
853 sum = var_loc
854#endif
855
856 end subroutine s_mpi_reduce_int_sum
857
858 !> Reduce a local real value to its global sum across all MPI ranks.
859 impure subroutine s_mpi_allreduce_sum(var_loc, var_glb)
860
861 real(wp), intent(in) :: var_loc
862 real(wp), intent(out) :: var_glb
863
864#ifdef MFC_MPI
865 integer :: ierr !< Generic flag used to identify and report MPI errors
866
867 call mpi_allreduce(var_loc, var_glb, 1, mpi_p, mpi_sum, mpi_comm_world, ierr)
868#endif
869
870 end subroutine s_mpi_allreduce_sum
871
872 !> Reduce an array of vectors to their global sums across all MPI ranks.
873 impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length)
874
875 integer, intent(in) :: num_vectors, vector_length
876 real(wp), dimension(:,:), intent(in) :: var_loc
877 real(wp), dimension(:,:), intent(inout) :: var_glb
878
879#ifdef MFC_MPI
880 integer :: ierr !< Generic flag used to identify and report MPI errors
881
882 if (loc(var_loc) == loc(var_glb)) then
883 call mpi_allreduce(mpi_in_place, var_glb, num_vectors*vector_length, mpi_p, mpi_sum, mpi_comm_world, ierr)
884 else
885 call mpi_allreduce(var_loc, var_glb, num_vectors*vector_length, mpi_p, mpi_sum, mpi_comm_world, ierr)
886 end if
887#else
888 var_glb(1:num_vectors,1:vector_length) = var_loc(1:num_vectors,1:vector_length)
889#endif
890
891 end subroutine s_mpi_allreduce_vectors_sum
892
893 !> Reduce a local integer value to its global sum across all MPI ranks.
894 impure subroutine s_mpi_allreduce_integer_sum(var_loc, var_glb)
895
896 integer(kind=8), intent(in) :: var_loc
897 integer(kind=8), intent(out) :: var_glb
898
899#ifdef MFC_MPI
900 integer :: ierr !< Generic flag used to identify and report MPI errors
901
902 call mpi_allreduce(var_loc, var_glb, 1, mpi_integer8, mpi_sum, mpi_comm_world, ierr)
903#else
904 var_glb = var_loc
905#endif
906
907 end subroutine s_mpi_allreduce_integer_sum
908
909 !> Reduce an integer(8) array to its element-wise global sum across all MPI ranks.
910 impure subroutine s_mpi_allreduce_integer_sum_vec(var_loc, var_glb)
911
912 integer(kind=8), dimension(:), intent(in) :: var_loc
913 integer(kind=8), dimension(:), intent(out) :: var_glb
914
915#ifdef MFC_MPI
916 integer :: ierr !< Generic flag used to identify and report MPI errors
917
918 call mpi_allreduce(var_loc, var_glb, size(var_loc), mpi_integer8, mpi_sum, mpi_comm_world, ierr)
919#else
920 var_glb = var_loc
921#endif
922
923 end subroutine s_mpi_allreduce_integer_sum_vec
924
925 !> Reduce a local real value to its global minimum across all MPI ranks.
926 impure subroutine s_mpi_allreduce_min(var_loc, var_glb)
927
928 real(wp), intent(in) :: var_loc
929 real(wp), intent(out) :: var_glb
930
931#ifdef MFC_MPI
932 integer :: ierr !< Generic flag used to identify and report MPI errors
933
934 call mpi_allreduce(var_loc, var_glb, 1, mpi_p, mpi_min, mpi_comm_world, ierr)
935#endif
936
937 end subroutine s_mpi_allreduce_min
938
939 !> Reduce a local real vector to its elementwise global minimum across all MPI ranks.
940 impure subroutine s_mpi_allreduce_min_vec(var_loc, var_glb)
941
942 real(wp), dimension(:), intent(in) :: var_loc
943 real(wp), dimension(:), intent(out) :: var_glb
944
945#ifdef MFC_MPI
946 integer :: ierr !< Generic flag used to identify and report MPI errors
947
948 call mpi_allreduce(var_loc, var_glb, size(var_loc), mpi_p, mpi_min, mpi_comm_world, ierr)
949#else
950 var_glb = var_loc
951#endif
952
953 end subroutine s_mpi_allreduce_min_vec
954
955 !> Reduce a local real value to its global maximum across all MPI ranks.
956 impure subroutine s_mpi_allreduce_max(var_loc, var_glb)
957
958 real(wp), intent(in) :: var_loc
959 real(wp), intent(out) :: var_glb
960
961#ifdef MFC_MPI
962 integer :: ierr !< Generic flag used to identify and report MPI errors
963
964 call mpi_allreduce(var_loc, var_glb, 1, mpi_p, mpi_max, mpi_comm_world, ierr)
965#endif
966
967 end subroutine s_mpi_allreduce_max
968
969 !> Reduce a local real value to its global minimum across all ranks
970 impure subroutine s_mpi_reduce_min(var_loc)
971
972 real(wp), intent(inout) :: var_loc
973
974#ifdef MFC_MPI
975 integer :: ierr !< Generic flag used to identify and report MPI errors
976 real(wp) :: var_glb
977
978 call mpi_reduce(var_loc, var_glb, 1, mpi_p, mpi_min, 0, mpi_comm_world, ierr)
979
980 call mpi_bcast(var_glb, 1, mpi_p, 0, mpi_comm_world, ierr)
981
982 var_loc = var_glb
983#endif
984
985 end subroutine s_mpi_reduce_min
986
987 !> Reduce a 2-element variable to its global maximum value with the owning processor rank (MPI_MAXLOC).
988 !> Reduce a local value to its global maximum with location (rank) across all ranks
989 impure subroutine s_mpi_reduce_maxloc(var_loc)
990
991 real(wp), dimension(2), intent(inout) :: var_loc
992
993#ifdef MFC_MPI
994 integer :: ierr !< Generic flag used to identify and report MPI errors
995 real(wp), dimension(2) :: var_glb !< Reduced (max value, rank) pair
996 call mpi_reduce(var_loc, var_glb, 1, mpi_2p, mpi_maxloc, 0, mpi_comm_world, ierr)
997
998 call mpi_bcast(var_glb, 1, mpi_2p, 0, mpi_comm_world, ierr)
999
1000 var_loc = var_glb
1001#endif
1002
1003 end subroutine s_mpi_reduce_maxloc
1004
1005 !> The subroutine terminates the MPI execution environment.
1006 impure subroutine s_mpi_abort(prnt, code)
1007
1008 character(len=*), intent(in), optional :: prnt
1009 integer, intent(in), optional :: code
1010
1011#ifdef MFC_MPI
1012 integer :: ierr !< Generic flag used to identify and report MPI errors
1013#endif
1014
1015 if (present(prnt)) then
1016 print *, prnt
1017 call flush (6)
1018 end if
1019
1020#ifndef MFC_MPI
1021 if (present(code)) then
1022 stop code
1023 else
1024 stop 1
1025 end if
1026#else
1027 if (present(code)) then
1028 call mpi_abort(mpi_comm_world, code, ierr)
1029 else
1030 call mpi_abort(mpi_comm_world, 1, ierr)
1031 end if
1032#endif
1033
1034 end subroutine s_mpi_abort
1035
1036 !> Abort naming the file if MPI_FILE_OPEN failed. File errors default to MPI_ERRORS_RETURN, so an unchecked failure carries on
1037 !! with an invalid handle and crashes somewhere unrelated.
1038 impure subroutine s_check_mpi_file_open(ierr, file_loc)
1039
1040 integer, intent(in) :: ierr
1041 character(len=*), intent(in) :: file_loc
1042
1043#ifdef MFC_MPI
1044 character(len=MPI_MAX_ERROR_STRING) :: msg
1045 integer :: msg_len, ierr2
1046
1047 if (ierr == mpi_success) return
1048 call mpi_error_string(ierr, msg, msg_len, ierr2)
1049 call s_mpi_abort('MPI_FILE_OPEN failed on ' // trim(file_loc) // ': ' // msg(1:msg_len))
1050#endif
1051
1052 end subroutine s_check_mpi_file_open
1053
1054 !> Halts all processes until all have reached barrier.
1055 impure subroutine s_mpi_barrier
1056
1057#ifdef MFC_MPI
1058 integer :: ierr !< Generic flag used to identify and report MPI errors
1059
1060 call mpi_barrier(mpi_comm_world, ierr)
1061#endif
1062
1063 end subroutine s_mpi_barrier
1064
1065 !> The subroutine finalizes the MPI execution environment.
1066 impure subroutine s_mpi_finalize
1067
1068#ifdef MFC_MPI
1069 integer :: ierr !< Generic flag used to identify and report MPI errors
1070
1071 call mpi_finalize(ierr)
1072#endif
1073
1074 end subroutine s_mpi_finalize
1075
1076 !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the
1077 !! neighboring processors.
1078 subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nVar, pb_in, mv_in, q_T_sf)
1079
1080 type(scalar_field), dimension(1:), intent(inout) :: q_comm
1081 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
1082 integer, intent(in) :: mpi_dir, pbc_loc, nVar
1083 integer :: i, j, k, l, r, q !< Generic loop iterators
1084 integer :: buffer_counts(1:3), buffer_count
1085 type(int_bounds_info) :: boundary_conditions(1:3)
1086 integer :: beg_end(1:2), grid_dims(1:3)
1087 integer :: dst_proc, src_proc, recv_tag, send_tag
1088 logical :: beg_end_geq_0, qbmm_comm, chem_diff_comm
1089 integer :: pack_offset, unpack_offset
1090 type(scalar_field), optional, intent(inout) :: q_T_sf
1091
1092#ifdef MFC_MPI
1093 integer :: ierr !< Generic flag used to identify and report MPI errors
1094
1095 call nvtxstartrange("RHS-COMM-PACKBUF")
1096
1097 qbmm_comm = .false.
1098 chem_diff_comm = .false.
1099
1100 if (present(pb_in) .and. present(mv_in) .and. qbmm .and. .not. polytropic) then
1101 qbmm_comm = .true.
1102 v_size = nvar + 2*nb*nnode
1103 buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), &
1104 & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/)
1105 else if (present(q_t_sf) .and. (heat_conduction .or. (chemistry .and. (chem_params%diffusion &
1106 & .or. exchange_all_chemistry_temperatures)))) then
1107 ! Consumers that convert over ghost-inclusive bounds request temperature exchange for every chemistry run.
1108 ! The temperature Newton guess must be valid at rank seams even when diffusion is disabled:
1109 ! an unexchanged seam ghost is an uninitialized guess -> NaN T/pres/c in the output
1110 chem_diff_comm = .true.
1111 v_size = nvar + 1
1112 buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), &
1113 & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/)
1114 else
1115 v_size = nvar
1116 buffer_counts = (/buff_size*v_size*(n + 1)*(p + 1), buff_size*v_size*(m + 2*buff_size + 1)*(p + 1), &
1117 & buff_size*v_size*(m + 2*buff_size + 1)*(n + 2*buff_size + 1)/)
1118 end if
1119
1120
1121# 628 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1122#if defined(MFC_OpenACC)
1123# 628 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1124!$acc update device(v_size)
1125# 628 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1126#elif defined(MFC_OpenMP)
1127# 628 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1128!$omp target update to(v_size)
1129# 628 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1130#endif
1131# 629 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1132
1133 buffer_count = buffer_counts(mpi_dir)
1134 boundary_conditions = (/bc_x, bc_y, bc_z/)
1135 beg_end = (/boundary_conditions(mpi_dir)%beg, boundary_conditions(mpi_dir)%end/)
1136 beg_end_geq_0 = beg_end(max(pbc_loc, 0) - pbc_loc + 1) >= 0
1137
1138 ! Implements: pbc_loc bc_x >= 0 -> [send/recv]_tag [dst/src]_proc -1 (=0) 0 -> [1,0] [0,0] | 0 0 [1,0] [beg,beg] -1 (=0) 1
1139 ! -> [0,0] [1,0] | 0 1 [0,0] [end,beg] +1 (=1) 0 -> [0,1] [1,1] | 1 0 [0,1] [end,end] +1 (=1) 1 -> [1,1] [0,1] | 1 1 [1,1]
1140 ! [beg,end]
1141
1142 send_tag = f_logical_to_int(.not. f_xor(beg_end_geq_0, pbc_loc == 1))
1143 recv_tag = f_logical_to_int(pbc_loc == 1)
1144
1145 dst_proc = beg_end(1 + f_logical_to_int(f_xor(pbc_loc == 1, beg_end_geq_0)))
1146 src_proc = beg_end(1 + f_logical_to_int(pbc_loc == 1))
1147
1148 grid_dims = (/m, n, p/)
1149
1150 pack_offset = 0
1151 if (f_xor(pbc_loc == 1, beg_end_geq_0)) then
1152 pack_offset = grid_dims(mpi_dir) - buff_size + 1
1153 end if
1154
1155 unpack_offset = 0
1156 if (pbc_loc == 1) then
1157 unpack_offset = grid_dims(mpi_dir) + buff_size + 1
1158 end if
1159
1160 ! Pack Buffer to Send
1161# 659 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1162 if (mpi_dir == 1) then
1163# 660 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1164# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1165
1166# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1167
1168# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1169#if defined(MFC_OpenACC)
1170# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1171!$acc parallel loop collapse(4) gang vector default(present) private(r)
1172# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1173#elif defined(MFC_OpenMP)
1174# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1175
1176# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1177
1178# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1179
1180# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1181!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1182# 661 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1183#endif
1184# 662 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1185 do l = 0, p
1186 do k = 0, n
1187 do j = 0, buff_size - 1
1188 do i = 1, nvar
1189 r = (i - 1) + v_size*(j + buff_size*(k + (n + 1)*l))
1190 buff_send(r) = real(q_comm(i)%sf(j + pack_offset, k, l), kind=wp)
1191 end do
1192 end do
1193 end do
1194 end do
1195
1196# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1197#if defined(MFC_OpenACC)
1198# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1199!$acc end parallel loop
1200# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1201#elif defined(MFC_OpenMP)
1202# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1203
1204# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1205!$omp end target teams loop
1206# 672 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1207#endif
1208# 673 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1209
1210 if (chem_diff_comm) then
1211
1212# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1213
1214# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1215#if defined(MFC_OpenACC)
1216# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1217!$acc parallel loop collapse(3) gang vector default(present) private(r)
1218# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1219#elif defined(MFC_OpenMP)
1220# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1221
1222# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1223
1224# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1225
1226# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1227!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1228# 675 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1229#endif
1230# 676 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1231 do l = 0, p
1232 do k = 0, n
1233 do j = 0, buff_size - 1
1234 r = nvar + v_size*(j + buff_size*(k + (n + 1)*l))
1235 buff_send(r) = real(q_t_sf%sf(j + pack_offset, k, l), kind=wp)
1236 end do
1237 end do
1238 end do
1239
1240# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1241#if defined(MFC_OpenACC)
1242# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1243!$acc end parallel loop
1244# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1245#elif defined(MFC_OpenMP)
1246# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1247
1248# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1249!$omp end target teams loop
1250# 684 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1251#endif
1252# 685 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1253 end if
1254
1255 if (qbmm_comm) then
1256
1257# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1258
1259# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1260#if defined(MFC_OpenACC)
1261# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1262!$acc parallel loop collapse(4) gang vector default(present) private(r)
1263# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1264#elif defined(MFC_OpenMP)
1265# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1266
1267# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1268
1269# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1270
1271# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1272!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1273# 688 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1274#endif
1275# 689 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1276 do l = 0, p
1277 do k = 0, n
1278 do j = 0, buff_size - 1
1279 do i = nvar + 1, nvar + nnode
1280 do q = 1, nb
1281 r = (i - 1) + (q - 1)*nnode + v_size*(j + buff_size*(k + (n + 1)*l))
1282 buff_send(r) = real(pb_in(j + pack_offset, k, l, i - nvar, q), kind=wp)
1283 end do
1284 end do
1285 end do
1286 end do
1287 end do
1288
1289# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1290#if defined(MFC_OpenACC)
1291# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1292!$acc end parallel loop
1293# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1294#elif defined(MFC_OpenMP)
1295# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1296
1297# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1298!$omp end target teams loop
1299# 701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1300#endif
1301# 702 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1302
1303
1304# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1305
1306# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1307#if defined(MFC_OpenACC)
1308# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1309!$acc parallel loop collapse(5) gang vector default(present) private(r)
1310# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1311#elif defined(MFC_OpenMP)
1312# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1313
1314# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1315
1316# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1317
1318# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1319!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1320# 703 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1321#endif
1322# 704 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1323 do l = 0, p
1324 do k = 0, n
1325 do j = 0, buff_size - 1
1326 do i = nvar + 1, nvar + nnode
1327 do q = 1, nb
1328 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*(j + buff_size*(k + (n + 1)*l))
1329 buff_send(r) = real(mv_in(j + pack_offset, k, l, i - nvar, q), kind=wp)
1330 end do
1331 end do
1332 end do
1333 end do
1334 end do
1335
1336# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1337#if defined(MFC_OpenACC)
1338# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1339!$acc end parallel loop
1340# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1341#elif defined(MFC_OpenMP)
1342# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1343
1344# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1345!$omp end target teams loop
1346# 716 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1347#endif
1348# 717 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1349 end if
1350# 841 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1351 end if
1352# 659 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1353 if (mpi_dir == 2) then
1354# 660 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1355# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1356
1357# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1358
1359# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1360#if defined(MFC_OpenACC)
1361# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1362!$acc parallel loop collapse(4) gang vector default(present) private(r)
1363# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1364#elif defined(MFC_OpenMP)
1365# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1366
1367# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1368
1369# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1370
1371# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1372!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1373# 719 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1374#endif
1375# 720 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1376 do i = 1, nvar
1377 do l = 0, p
1378 do k = 0, buff_size - 1
1379 do j = -buff_size, m + buff_size
1380 r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k + buff_size*l))
1381 buff_send(r) = real(q_comm(i)%sf(j, k + pack_offset, l), kind=wp)
1382 end do
1383 end do
1384 end do
1385 end do
1386
1387# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1388#if defined(MFC_OpenACC)
1389# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1390!$acc end parallel loop
1391# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1392#elif defined(MFC_OpenMP)
1393# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1394
1395# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1396!$omp end target teams loop
1397# 730 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1398#endif
1399# 731 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1400
1401 if (chem_diff_comm) then
1402
1403# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1404
1405# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1406#if defined(MFC_OpenACC)
1407# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1408!$acc parallel loop collapse(3) gang vector default(present) private(r)
1409# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1410#elif defined(MFC_OpenMP)
1411# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1412
1413# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1414
1415# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1416
1417# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1418!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1419# 733 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1420#endif
1421# 734 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1422 do l = 0, p
1423 do k = 0, buff_size - 1
1424 do j = -buff_size, m + buff_size
1425 r = nvar + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k + buff_size*l))
1426 buff_send(r) = real(q_t_sf%sf(j, k + pack_offset, l), kind=wp)
1427 end do
1428 end do
1429 end do
1430
1431# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1432#if defined(MFC_OpenACC)
1433# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1434!$acc end parallel loop
1435# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1436#elif defined(MFC_OpenMP)
1437# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1438
1439# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1440!$omp end target teams loop
1441# 742 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1442#endif
1443# 743 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1444 end if
1445
1446 if (qbmm_comm) then
1447
1448# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1449
1450# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1451#if defined(MFC_OpenACC)
1452# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1453!$acc parallel loop collapse(5) gang vector default(present) private(r)
1454# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1455#elif defined(MFC_OpenMP)
1456# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1457
1458# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1459
1460# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1461
1462# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1463!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1464# 746 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1465#endif
1466# 747 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1467 do i = nvar + 1, nvar + nnode
1468 do l = 0, p
1469 do k = 0, buff_size - 1
1470 do j = -buff_size, m + buff_size
1471 do q = 1, nb
1472 r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*(k &
1473 & + buff_size*l))
1474 buff_send(r) = real(pb_in(j, k + pack_offset, l, i - nvar, q), kind=wp)
1475 end do
1476 end do
1477 end do
1478 end do
1479 end do
1480
1481# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1482#if defined(MFC_OpenACC)
1483# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1484!$acc end parallel loop
1485# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1486#elif defined(MFC_OpenMP)
1487# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1488
1489# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1490!$omp end target teams loop
1491# 760 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1492#endif
1493# 761 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1494
1495
1496# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1497
1498# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1499#if defined(MFC_OpenACC)
1500# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1501!$acc parallel loop collapse(5) gang vector default(present) private(r)
1502# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1503#elif defined(MFC_OpenMP)
1504# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1505
1506# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1507
1508# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1509
1510# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1511!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1512# 762 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1513#endif
1514# 763 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1515 do i = nvar + 1, nvar + nnode
1516 do l = 0, p
1517 do k = 0, buff_size - 1
1518 do j = -buff_size, m + buff_size
1519 do q = 1, nb
1520 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size &
1521 & + 1)*(k + buff_size*l))
1522 buff_send(r) = real(mv_in(j, k + pack_offset, l, i - nvar, q), kind=wp)
1523 end do
1524 end do
1525 end do
1526 end do
1527 end do
1528
1529# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1530#if defined(MFC_OpenACC)
1531# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1532!$acc end parallel loop
1533# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1534#elif defined(MFC_OpenMP)
1535# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1536
1537# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1538!$omp end target teams loop
1539# 776 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1540#endif
1541# 777 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1542 end if
1543# 841 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1544 end if
1545# 659 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1546 if (mpi_dir == 3) then
1547# 660 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1548# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1549
1550# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1551
1552# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1553#if defined(MFC_OpenACC)
1554# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1555!$acc parallel loop collapse(4) gang vector default(present) private(r)
1556# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1557#elif defined(MFC_OpenMP)
1558# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1559
1560# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1561
1562# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1563
1564# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1565!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1566# 779 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1567#endif
1568# 780 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1569 do i = 1, nvar
1570 do l = 0, buff_size - 1
1571 do k = -buff_size, n + buff_size
1572 do j = -buff_size, m + buff_size
1573 r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n &
1574 & + 2*buff_size + 1)*l))
1575 buff_send(r) = real(q_comm(i)%sf(j, k, l + pack_offset), kind=wp)
1576 end do
1577 end do
1578 end do
1579 end do
1580
1581# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1582#if defined(MFC_OpenACC)
1583# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1584!$acc end parallel loop
1585# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1586#elif defined(MFC_OpenMP)
1587# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1588
1589# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1590!$omp end target teams loop
1591# 791 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1592#endif
1593# 792 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1594
1595 if (chem_diff_comm) then
1596
1597# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1598
1599# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1600#if defined(MFC_OpenACC)
1601# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1602!$acc parallel loop collapse(3) gang vector default(present) private(r)
1603# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1604#elif defined(MFC_OpenMP)
1605# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1606
1607# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1608
1609# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1610
1611# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1612!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1613# 794 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1614#endif
1615# 795 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1616 do l = 0, buff_size - 1
1617 do k = -buff_size, n + buff_size
1618 do j = -buff_size, m + buff_size
1619 r = nvar + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n &
1620 & + 2*buff_size + 1)*l))
1621 buff_send(r) = real(q_t_sf%sf(j, k, l + pack_offset), kind=wp)
1622 end do
1623 end do
1624 end do
1625
1626# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1627#if defined(MFC_OpenACC)
1628# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1629!$acc end parallel loop
1630# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1631#elif defined(MFC_OpenMP)
1632# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1633
1634# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1635!$omp end target teams loop
1636# 804 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1637#endif
1638# 805 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1639 end if
1640
1641 if (qbmm_comm) then
1642
1643# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1644
1645# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1646#if defined(MFC_OpenACC)
1647# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1648!$acc parallel loop collapse(5) gang vector default(present) private(r)
1649# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1650#elif defined(MFC_OpenMP)
1651# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1652
1653# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1654
1655# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1656
1657# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1658!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1659# 808 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1660#endif
1661# 809 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1662 do i = nvar + 1, nvar + nnode
1663 do l = 0, buff_size - 1
1664 do k = -buff_size, n + buff_size
1665 do j = -buff_size, m + buff_size
1666 do q = 1, nb
1667 r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k &
1668 & + buff_size) + (n + 2*buff_size + 1)*l))
1669 buff_send(r) = real(pb_in(j, k, l + pack_offset, i - nvar, q), kind=wp)
1670 end do
1671 end do
1672 end do
1673 end do
1674 end do
1675
1676# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1677#if defined(MFC_OpenACC)
1678# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1679!$acc end parallel loop
1680# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1681#elif defined(MFC_OpenMP)
1682# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1683
1684# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1685!$omp end target teams loop
1686# 822 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1687#endif
1688# 823 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1689
1690
1691# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1692
1693# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1694#if defined(MFC_OpenACC)
1695# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1696!$acc parallel loop collapse(5) gang vector default(present) private(r)
1697# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1698#elif defined(MFC_OpenMP)
1699# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1700
1701# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1702
1703# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1704
1705# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1706!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1707# 824 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1708#endif
1709# 825 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1710 do i = nvar + 1, nvar + nnode
1711 do l = 0, buff_size - 1
1712 do k = -buff_size, n + buff_size
1713 do j = -buff_size, m + buff_size
1714 do q = 1, nb
1715 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size &
1716 & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*l))
1717 buff_send(r) = real(mv_in(j, k, l + pack_offset, i - nvar, q), kind=wp)
1718 end do
1719 end do
1720 end do
1721 end do
1722 end do
1723
1724# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1725#if defined(MFC_OpenACC)
1726# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1727!$acc end parallel loop
1728# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1729#elif defined(MFC_OpenMP)
1730# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1731
1732# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1733!$omp end target teams loop
1734# 838 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1735#endif
1736# 839 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1737 end if
1738# 841 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1739 end if
1740# 843 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1741 call nvtxendrange ! Packbuf
1742
1743 ! Send/Recv
1744# 847 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1745 if (use_rdma_transport .eqv. .false.) then
1746# 848 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1747# 859 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1748 call nvtxstartrange("RHS-COMM-DEV2HOST")
1749
1750# 860 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1751#if defined(MFC_OpenACC)
1752# 860 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1753!$acc update host(buff_send)
1754# 860 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1755#elif defined(MFC_OpenMP)
1756# 860 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1757!$omp target update from(buff_send)
1758# 860 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1759#endif
1760# 861 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1761 call nvtxendrange
1762 call nvtxstartrange("RHS-COMM-SENDRECV-NO-RMDA")
1763
1764 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
1765 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
1766
1767 call nvtxendrange ! RHS-MPI-SENDRECV-(NO)-RDMA
1768
1769 call nvtxstartrange("RHS-COMM-HOST2DEV")
1770
1771# 870 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1772#if defined(MFC_OpenACC)
1773# 870 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1774!$acc update device(buff_recv)
1775# 870 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1776#elif defined(MFC_OpenMP)
1777# 870 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1778!$omp target update to(buff_recv)
1779# 870 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1780#endif
1781# 871 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1782 call nvtxendrange
1783# 873 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1784 end if
1785# 847 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1786 if (use_rdma_transport .eqv. .true.) then
1787# 848 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1788# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1789
1790# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1791#if defined(MFC_OpenACC)
1792# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1793!$acc host_data use_device(buff_send, buff_recv)
1794# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1795 call nvtxstartrange("RHS-COMM-SENDRECV-RDMA")
1796# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1797
1798# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1799 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
1800# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1801 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
1802# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1803
1804# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1805 call nvtxendrange ! RHS-MPI-SENDRECV-(NO)-RDMA
1806# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1807!$acc end host_data
1808# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1809#elif defined(MFC_OpenMP)
1810# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1811!$omp target data use_device_addr(buff_send, buff_recv)
1812# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1813 call nvtxstartrange("RHS-COMM-SENDRECV-RDMA")
1814# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1815
1816# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1817 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
1818# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1819 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
1820# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1821
1822# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1823 call nvtxendrange ! RHS-MPI-SENDRECV-(NO)-RDMA
1824# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1825!$omp end target data
1826# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1827#else
1828# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1829 call nvtxstartrange("RHS-COMM-SENDRECV-RDMA")
1830# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1831
1832# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1833 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
1834# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1835 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
1836# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1837
1838# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1839 call nvtxendrange ! RHS-MPI-SENDRECV-(NO)-RDMA
1840# 849 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1841#endif
1842# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1843
1844# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1845#if defined(MFC_OpenACC)
1846# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1847!$acc wait
1848# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1849#elif defined(MFC_OpenMP)
1850# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1851!$omp barrier
1852# 857 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1853#endif
1854# 858 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1855# 873 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1856 end if
1857# 875 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1858
1859 ! Unpack Received Buffer
1860 call nvtxstartrange("RHS-COMM-UNPACKBUF")
1861# 879 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1862 if (mpi_dir == 1) then
1863# 880 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1864# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1865
1866# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1867
1868# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1869#if defined(MFC_OpenACC)
1870# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1871!$acc parallel loop collapse(4) gang vector default(present) private(r)
1872# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1873#elif defined(MFC_OpenMP)
1874# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1875
1876# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1877
1878# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1879
1880# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1881!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1882# 881 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1883#endif
1884# 882 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1885 do l = 0, p
1886 do k = 0, n
1887 do j = -buff_size, -1
1888 do i = 1, nvar
1889 r = (i - 1) + v_size*(j + buff_size*((k + 1) + (n + 1)*l))
1890 q_comm(i)%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp)
1891#if defined(__INTEL_COMPILER)
1892 if (ieee_is_nan(q_comm(i)%sf(j + unpack_offset, k, l))) then
1893 print *, "Error", j, k, l, i
1894 call s_mpi_abort("NaN(s) in recv")
1895 end if
1896#endif
1897 end do
1898 end do
1899 end do
1900 end do
1901
1902# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1903#if defined(MFC_OpenACC)
1904# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1905!$acc end parallel loop
1906# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1907#elif defined(MFC_OpenMP)
1908# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1909
1910# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1911!$omp end target teams loop
1912# 898 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1913#endif
1914# 899 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1915
1916 if (chem_diff_comm) then
1917
1918# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1919
1920# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1921#if defined(MFC_OpenACC)
1922# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1923!$acc parallel loop collapse(3) gang vector default(present) private(r)
1924# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1925#elif defined(MFC_OpenMP)
1926# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1927
1928# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1929
1930# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1931
1932# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1933!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1934# 901 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1935#endif
1936# 902 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1937 do l = 0, p
1938 do k = 0, n
1939 do j = -buff_size, -1
1940 r = nvar + v_size*(j + buff_size*((k + 1) + (n + 1)*l))
1941 q_t_sf%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp)
1942#if defined(__INTEL_COMPILER)
1943 if (ieee_is_nan(q_t_sf%sf(j + unpack_offset, k, l))) then
1944 print *, "Error", j, k, l
1945 call s_mpi_abort("NaN(s) in recv")
1946 end if
1947#endif
1948 end do
1949 end do
1950 end do
1951
1952# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1953#if defined(MFC_OpenACC)
1954# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1955!$acc end parallel loop
1956# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1957#elif defined(MFC_OpenMP)
1958# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1959
1960# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1961!$omp end target teams loop
1962# 916 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1963#endif
1964# 917 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1965 end if
1966
1967 if (qbmm_comm) then
1968
1969# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1970
1971# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1972#if defined(MFC_OpenACC)
1973# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1974!$acc parallel loop collapse(5) gang vector default(present) private(r)
1975# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1976#elif defined(MFC_OpenMP)
1977# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1978
1979# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1980
1981# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1982
1983# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1984!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
1985# 920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1986#endif
1987# 921 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
1988 do l = 0, p
1989 do k = 0, n
1990 do j = -buff_size, -1
1991 do i = nvar + 1, nvar + nnode
1992 do q = 1, nb
1993 r = (i - 1) + (q - 1)*nnode + v_size*(j + buff_size*((k + 1) + (n + 1)*l))
1994 pb_in(j + unpack_offset, k, l, i - nvar, q) = real(buff_recv(r), kind=stp)
1995 end do
1996 end do
1997 end do
1998 end do
1999 end do
2000
2001# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2002#if defined(MFC_OpenACC)
2003# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2004!$acc end parallel loop
2005# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2006#elif defined(MFC_OpenMP)
2007# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2008
2009# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2010!$omp end target teams loop
2011# 933 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2012#endif
2013# 934 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2014
2015
2016# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2017
2018# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2019#if defined(MFC_OpenACC)
2020# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2021!$acc parallel loop collapse(5) gang vector default(present) private(r)
2022# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2023#elif defined(MFC_OpenMP)
2024# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2025
2026# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2027
2028# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2029
2030# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2031!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2032# 935 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2033#endif
2034# 936 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2035 do l = 0, p
2036 do k = 0, n
2037 do j = -buff_size, -1
2038 do i = nvar + 1, nvar + nnode
2039 do q = 1, nb
2040 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*(j + buff_size*((k + 1) + (n + 1)*l))
2041 mv_in(j + unpack_offset, k, l, i - nvar, q) = real(buff_recv(r), kind=stp)
2042 end do
2043 end do
2044 end do
2045 end do
2046 end do
2047
2048# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2049#if defined(MFC_OpenACC)
2050# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2051!$acc end parallel loop
2052# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2053#elif defined(MFC_OpenMP)
2054# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2055
2056# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2057!$omp end target teams loop
2058# 948 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2059#endif
2060# 949 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2061 end if
2062# 1097 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2063 end if
2064# 879 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2065 if (mpi_dir == 2) then
2066# 880 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2067# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2068
2069# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2070
2071# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2072#if defined(MFC_OpenACC)
2073# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2074!$acc parallel loop collapse(4) gang vector default(present) private(r)
2075# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2076#elif defined(MFC_OpenMP)
2077# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2078
2079# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2080
2081# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2082
2083# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2084!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2085# 951 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2086#endif
2087# 952 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2088 do i = 1, nvar
2089 do l = 0, p
2090 do k = -buff_size, -1
2091 do j = -buff_size, m + buff_size
2092 r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + buff_size*l))
2093 q_comm(i)%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp)
2094#if defined(__INTEL_COMPILER)
2095 if (ieee_is_nan(q_comm(i)%sf(j, k + unpack_offset, l))) then
2096 print *, "Error", j, k, l, i
2097 call s_mpi_abort("NaN(s) in recv")
2098 end if
2099#endif
2100 end do
2101 end do
2102 end do
2103 end do
2104
2105# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2106#if defined(MFC_OpenACC)
2107# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2108!$acc end parallel loop
2109# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2110#elif defined(MFC_OpenMP)
2111# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2112
2113# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2114!$omp end target teams loop
2115# 968 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2116#endif
2117# 969 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2118
2119 if (chem_diff_comm) then
2120
2121# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2122
2123# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2124#if defined(MFC_OpenACC)
2125# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2126!$acc parallel loop collapse(3) gang vector default(present) private(r)
2127# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2128#elif defined(MFC_OpenMP)
2129# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2130
2131# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2132
2133# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2134
2135# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2136!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2137# 971 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2138#endif
2139# 972 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2140 do l = 0, p
2141 do k = -buff_size, -1
2142 do j = -buff_size, m + buff_size
2143 r = nvar + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + buff_size*l))
2144 q_t_sf%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp)
2145#if defined(__INTEL_COMPILER)
2146 if (ieee_is_nan(q_t_sf%sf(j, k + unpack_offset, l))) then
2147 print *, "Error", j, k, l
2148 call s_mpi_abort("NaN(s) in recv")
2149 end if
2150#endif
2151 end do
2152 end do
2153 end do
2154
2155# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2156#if defined(MFC_OpenACC)
2157# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2158!$acc end parallel loop
2159# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2160#elif defined(MFC_OpenMP)
2161# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2162
2163# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2164!$omp end target teams loop
2165# 986 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2166#endif
2167# 987 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2168 end if
2169
2170 if (qbmm_comm) then
2171
2172# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2173
2174# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2175#if defined(MFC_OpenACC)
2176# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2177!$acc parallel loop collapse(5) gang vector default(present) private(r)
2178# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2179#elif defined(MFC_OpenMP)
2180# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2181
2182# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2183
2184# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2185
2186# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2187!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2188# 990 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2189#endif
2190# 991 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2191 do i = nvar + 1, nvar + nnode
2192 do l = 0, p
2193 do k = -buff_size, -1
2194 do j = -buff_size, m + buff_size
2195 do q = 1, nb
2196 r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k &
2197 & + buff_size) + buff_size*l))
2198 pb_in(j, k + unpack_offset, l, i - nvar, q) = real(buff_recv(r), kind=stp)
2199 end do
2200 end do
2201 end do
2202 end do
2203 end do
2204
2205# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2206#if defined(MFC_OpenACC)
2207# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2208!$acc end parallel loop
2209# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2210#elif defined(MFC_OpenMP)
2211# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2212
2213# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2214!$omp end target teams loop
2215# 1004 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2216#endif
2217# 1005 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2218
2219
2220# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2221
2222# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2223#if defined(MFC_OpenACC)
2224# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2225!$acc parallel loop collapse(5) gang vector default(present) private(r)
2226# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2227#elif defined(MFC_OpenMP)
2228# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2229
2230# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2231
2232# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2233
2234# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2235!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2236# 1006 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2237#endif
2238# 1007 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2239 do i = nvar + 1, nvar + nnode
2240 do l = 0, p
2241 do k = -buff_size, -1
2242 do j = -buff_size, m + buff_size
2243 do q = 1, nb
2244 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size &
2245 & + 1)*((k + buff_size) + buff_size*l))
2246 mv_in(j, k + unpack_offset, l, i - nvar, q) = real(buff_recv(r), kind=stp)
2247 end do
2248 end do
2249 end do
2250 end do
2251 end do
2252
2253# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2254#if defined(MFC_OpenACC)
2255# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2256!$acc end parallel loop
2257# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2258#elif defined(MFC_OpenMP)
2259# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2260
2261# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2262!$omp end target teams loop
2263# 1020 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2264#endif
2265# 1021 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2266 end if
2267# 1097 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2268 end if
2269# 879 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2270 if (mpi_dir == 3) then
2271# 880 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2272# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2273
2274# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2275
2276# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2277#if defined(MFC_OpenACC)
2278# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2279!$acc parallel loop collapse(4) gang vector default(present) private(r)
2280# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2281#elif defined(MFC_OpenMP)
2282# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2283
2284# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2285
2286# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2287
2288# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2289!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2290# 1023 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2291#endif
2292# 1024 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2293 do i = 1, nvar
2294 do l = -buff_size, -1
2295 do k = -buff_size, n + buff_size
2296 do j = -buff_size, m + buff_size
2297 r = (i - 1) + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n &
2298 & + 2*buff_size + 1)*(l + buff_size)))
2299 q_comm(i)%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp)
2300#if defined(__INTEL_COMPILER)
2301 if (ieee_is_nan(q_comm(i)%sf(j, k, l + unpack_offset))) then
2302 print *, "Error", j, k, l, i
2303 call s_mpi_abort("NaN(s) in recv")
2304 end if
2305#endif
2306 end do
2307 end do
2308 end do
2309 end do
2310
2311# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2312#if defined(MFC_OpenACC)
2313# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2314!$acc end parallel loop
2315# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2316#elif defined(MFC_OpenMP)
2317# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2318
2319# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2320!$omp end target teams loop
2321# 1041 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2322#endif
2323# 1042 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2324
2325 if (chem_diff_comm) then
2326
2327# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2328
2329# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2330#if defined(MFC_OpenACC)
2331# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2332!$acc parallel loop collapse(3) gang vector default(present) private(r)
2333# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2334#elif defined(MFC_OpenMP)
2335# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2336
2337# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2338
2339# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2340
2341# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2342!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2343# 1044 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2344#endif
2345# 1045 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2346 do l = -buff_size, -1
2347 do k = -buff_size, n + buff_size
2348 do j = -buff_size, m + buff_size
2349 r = nvar + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k + buff_size) + (n &
2350 & + 2*buff_size + 1)*(l + buff_size)))
2351 q_t_sf%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp)
2352#if defined(__INTEL_COMPILER)
2353 if (ieee_is_nan(q_t_sf%sf(j, k, l + unpack_offset))) then
2354 print *, "Error", j, k, l
2355 call s_mpi_abort("NaN(s) in recv")
2356 end if
2357#endif
2358 end do
2359 end do
2360 end do
2361
2362# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2363#if defined(MFC_OpenACC)
2364# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2365!$acc end parallel loop
2366# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2367#elif defined(MFC_OpenMP)
2368# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2369
2370# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2371!$omp end target teams loop
2372# 1060 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2373#endif
2374# 1061 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2375 end if
2376
2377 if (qbmm_comm) then
2378
2379# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2380
2381# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2382#if defined(MFC_OpenACC)
2383# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2384!$acc parallel loop collapse(5) gang vector default(present) private(r)
2385# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2386#elif defined(MFC_OpenMP)
2387# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2388
2389# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2390
2391# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2392
2393# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2394!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2395# 1064 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2396#endif
2397# 1065 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2398 do i = nvar + 1, nvar + nnode
2399 do l = -buff_size, -1
2400 do k = -buff_size, n + buff_size
2401 do j = -buff_size, m + buff_size
2402 do q = 1, nb
2403 r = (i - 1) + (q - 1)*nnode + v_size*((j + buff_size) + (m + 2*buff_size + 1)*((k &
2404 & + buff_size) + (n + 2*buff_size + 1)*(l + buff_size)))
2405 pb_in(j, k, l + unpack_offset, i - nvar, q) = real(buff_recv(r), kind=stp)
2406 end do
2407 end do
2408 end do
2409 end do
2410 end do
2411
2412# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2413#if defined(MFC_OpenACC)
2414# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2415!$acc end parallel loop
2416# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2417#elif defined(MFC_OpenMP)
2418# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2419
2420# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2421!$omp end target teams loop
2422# 1078 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2423#endif
2424# 1079 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2425
2426
2427# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2428
2429# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2430#if defined(MFC_OpenACC)
2431# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2432!$acc parallel loop collapse(5) gang vector default(present) private(r)
2433# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2434#elif defined(MFC_OpenMP)
2435# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2436
2437# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2438
2439# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2440
2441# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2442!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(5) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2443# 1080 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2444#endif
2445# 1081 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2446 do i = nvar + 1, nvar + nnode
2447 do l = -buff_size, -1
2448 do k = -buff_size, n + buff_size
2449 do j = -buff_size, m + buff_size
2450 do q = 1, nb
2451 r = (i - 1) + (q - 1)*nnode + nb*nnode + v_size*((j + buff_size) + (m + 2*buff_size &
2452 & + 1)*((k + buff_size) + (n + 2*buff_size + 1)*(l + buff_size)))
2453 mv_in(j, k, l + unpack_offset, i - nvar, q) = real(buff_recv(r), kind=stp)
2454 end do
2455 end do
2456 end do
2457 end do
2458 end do
2459
2460# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2461#if defined(MFC_OpenACC)
2462# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2463!$acc end parallel loop
2464# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2465#elif defined(MFC_OpenMP)
2466# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2467
2468# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2469!$omp end target teams loop
2470# 1094 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2471#endif
2472# 1095 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2473 end if
2474# 1097 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2475 end if
2476# 1099 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2477 call nvtxendrange
2478#endif
2479
2480 end subroutine s_mpi_sendrecv_variables_buffers
2481
2482 !> The goal of this procedure is to populate the buffers of the cell-average conservative variables by communicating with the
2483 !! neighboring processors.
2484 !! @param q_cons_vf Cell-average conservative variables
2485 !! @param mpi_dir MPI communication coordinate direction
2486 !! @param pbc_loc Processor boundary condition (PBC) location
2487 subroutine s_mpi_reduce_beta_variables_buffers(q_comm, kahan_comp, mpi_dir, pbc_loc, nVar)
2488
2489 type(scalar_field), dimension(1:), intent(inout) :: q_comm
2490 type(scalar_field), dimension(1:), intent(inout) :: kahan_comp
2491 integer, intent(in) :: mpi_dir, pbc_loc, nVar
2492 integer :: i, j, k, l, r, q !< Generic loop iterators
2493 integer :: lb_size
2494 integer :: buffer_counts(1:3), buffer_count
2495 type(int_bounds_info) :: boundary_conditions(1:3)
2496 integer :: beg_end(1:2), grid_dims(1:3)
2497 integer :: dst_proc, src_proc, recv_tag, send_tag
2498 logical :: replace_buff
2499 integer :: pack_offset, unpack_offset
2500 real(wp) :: y_kahan, t_kahan
2501
2502#ifdef MFC_MPI
2503 integer :: ierr !< Generic flag used to identify and report MPI errors
2504
2505 call nvtxstartrange("BETA-COMM-PACKBUF")
2506
2507 ! Set bounds for each dimension Always include the full buffer range for each existing dimension. The Gaussian smearing
2508 ! kernel writes to buffer cells even at physical boundaries, and these contributions must be communicated to neighbors in
2509 ! other directions via ADD operations.
2510 comm_coords(1)%beg = -mapcells - 1
2511 comm_coords(1)%end = m + mapcells + 1
2512 comm_coords(2)%beg = merge(-mapcells - 1, 0, n > 0)
2513 comm_coords(2)%end = merge(n + mapcells + 1, n, n > 0)
2514 comm_coords(3)%beg = merge(-mapcells - 1, 0, p > 0)
2515 comm_coords(3)%end = merge(p + mapcells + 1, p, p > 0)
2516
2517 ! Compute sizes
2518 comm_size(1) = comm_coords(1)%end - comm_coords(1)%beg + 1
2519 comm_size(2) = comm_coords(2)%end - comm_coords(2)%beg + 1
2520 comm_size(3) = comm_coords(3)%end - comm_coords(3)%beg + 1
2521
2522 ! Buffer counts using the conditional sizes
2523 v_size = nvar
2524 lb_size = 2*(mapcells + 1) ! Size of the buffer region for beta variables (-mapcells - 1, mapcells)
2525 buffer_counts = (/lb_size*v_size*comm_size(2)*comm_size(3), lb_size*v_size*comm_size(1)*comm_size(3), &
2526 & lb_size*v_size*comm_size(1)*comm_size(2)/)
2527
2528
2529# 1150 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2530#if defined(MFC_OpenACC)
2531# 1150 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2532!$acc update device(v_size, comm_coords, comm_size)
2533# 1150 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2534#elif defined(MFC_OpenMP)
2535# 1150 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2536!$omp target update to(v_size, comm_coords, comm_size)
2537# 1150 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2538#endif
2539# 1151 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2540
2541 buffer_count = buffer_counts(mpi_dir)
2542 boundary_conditions = (/bc_x, bc_y, bc_z/)
2543 beg_end = (/boundary_conditions(mpi_dir)%beg, boundary_conditions(mpi_dir)%end/)
2544 grid_dims = (/m, n, p/)
2545
2546 if (pbc_loc == -1) then ! PBC at the beginning
2547 ! Phase 1: Rightward accumulation Send END buffer to right neighbor, recv from left into BEG, ADD
2548 pack_offset = grid_dims(mpi_dir) + 1
2549 unpack_offset = 0
2550 dst_proc = merge(beg_end(2), mpi_proc_null, beg_end(2) >= 0)
2551 src_proc = merge(beg_end(1), mpi_proc_null, beg_end(1) >= 0)
2552 send_tag = 0
2553 recv_tag = 0
2554 replace_buff = .false.
2555 else
2556 ! Phase 2: Leftward distribution Send BEG buffer to left neighbor, recv from right into END, REPLACE
2557 pack_offset = 0
2558 unpack_offset = grid_dims(mpi_dir) + 1
2559 dst_proc = merge(beg_end(1), mpi_proc_null, beg_end(1) >= 0)
2560 src_proc = merge(beg_end(2), mpi_proc_null, beg_end(2) >= 0)
2561 send_tag = 1
2562 recv_tag = 1
2563 replace_buff = .true.
2564 end if
2565
2566 ! Pack Buffer to Send
2567# 1179 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2568 if (mpi_dir == 1) then
2569# 1180 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2570# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2571
2572# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2573
2574# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2575#if defined(MFC_OpenACC)
2576# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2577!$acc parallel loop collapse(4) gang vector default(present) private(r)
2578# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2579#elif defined(MFC_OpenMP)
2580# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2581
2582# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2583
2584# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2585
2586# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2587!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2588# 1181 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2589#endif
2590# 1182 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2591 do l = comm_coords(3)%beg, comm_coords(3)%end
2592 do k = comm_coords(2)%beg, comm_coords(2)%end
2593 do j = -mapcells - 1, mapcells
2594 do i = 1, v_size
2595 r = (i - 1) + v_size*((j + mapcells + 1) + lb_size*((k - comm_coords(2)%beg) + comm_size(2) &
2596 & *(l - comm_coords(3)%beg)))
2597 buff_send(r) = real(q_comm(beta_vars(i))%sf(j + pack_offset, k, l), &
2598 & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j + pack_offset, k, l), kind=wp)
2599 end do
2600 end do
2601 end do
2602 end do
2603
2604# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2605#if defined(MFC_OpenACC)
2606# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2607!$acc end parallel loop
2608# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2609#elif defined(MFC_OpenMP)
2610# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2611
2612# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2613!$omp end target teams loop
2614# 1194 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2615#endif
2616# 1195 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2617# 1226 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2618 end if
2619# 1179 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2620 if (mpi_dir == 2) then
2621# 1180 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2622# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2623
2624# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2625
2626# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2627#if defined(MFC_OpenACC)
2628# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2629!$acc parallel loop collapse(4) gang vector default(present) private(r)
2630# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2631#elif defined(MFC_OpenMP)
2632# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2633
2634# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2635
2636# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2637
2638# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2639!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2640# 1196 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2641#endif
2642# 1197 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2643 do i = 1, v_size
2644 do l = comm_coords(3)%beg, comm_coords(3)%end
2645 do k = -mapcells - 1, mapcells
2646 do j = comm_coords(1)%beg, comm_coords(1)%end
2647 r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k + mapcells + 1) &
2648 & + lb_size*(l - comm_coords(3)%beg)))
2649 buff_send(r) = real(q_comm(beta_vars(i))%sf(j, k + pack_offset, l), &
2650 & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j, k + pack_offset, l), kind=wp)
2651 end do
2652 end do
2653 end do
2654 end do
2655
2656# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2657#if defined(MFC_OpenACC)
2658# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2659!$acc end parallel loop
2660# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2661#elif defined(MFC_OpenMP)
2662# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2663
2664# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2665!$omp end target teams loop
2666# 1209 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2667#endif
2668# 1210 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2669# 1226 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2670 end if
2671# 1179 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2672 if (mpi_dir == 3) then
2673# 1180 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2674# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2675
2676# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2677
2678# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2679#if defined(MFC_OpenACC)
2680# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2681!$acc parallel loop collapse(4) gang vector default(present) private(r)
2682# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2683#elif defined(MFC_OpenMP)
2684# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2685
2686# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2687
2688# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2689
2690# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2691!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(r)
2692# 1211 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2693#endif
2694# 1212 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2695 do i = 1, v_size
2696 do l = -mapcells - 1, mapcells
2697 do k = comm_coords(2)%beg, comm_coords(2)%end
2698 do j = comm_coords(1)%beg, comm_coords(1)%end
2699 r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k - comm_coords(2)%beg) &
2700 & + comm_size(2)*(l + mapcells + 1)))
2701 buff_send(r) = real(q_comm(beta_vars(i))%sf(j, k, l + pack_offset), &
2702 & kind=wp) - real(kahan_comp(beta_vars(i))%sf(j, k, l + pack_offset), kind=wp)
2703 end do
2704 end do
2705 end do
2706 end do
2707
2708# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2709#if defined(MFC_OpenACC)
2710# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2711!$acc end parallel loop
2712# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2713#elif defined(MFC_OpenMP)
2714# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2715
2716# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2717!$omp end target teams loop
2718# 1224 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2719#endif
2720# 1225 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2721# 1226 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2722 end if
2723# 1228 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2724 call nvtxendrange ! Packbuf
2725
2726 ! Send/Recv
2727# 1232 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2728 if (use_rdma_transport .eqv. .false.) then
2729# 1233 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2730# 1244 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2731 call nvtxstartrange("BETA-COMM-DEV2HOST")
2732
2733# 1245 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2734#if defined(MFC_OpenACC)
2735# 1245 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2736!$acc update host(buff_send)
2737# 1245 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2738#elif defined(MFC_OpenMP)
2739# 1245 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2740!$omp target update from(buff_send)
2741# 1245 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2742#endif
2743# 1246 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2744 call nvtxendrange
2745 call nvtxstartrange("BETA-COMM-SENDRECV-NO-RMDA")
2746
2747 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
2748 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
2749
2750 call nvtxendrange ! BETA-MPI-SENDRECV-(NO)-RDMA
2751
2752 call nvtxstartrange("BETA-COMM-HOST2DEV")
2753
2754# 1255 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2755#if defined(MFC_OpenACC)
2756# 1255 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2757!$acc update device(buff_recv)
2758# 1255 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2759#elif defined(MFC_OpenMP)
2760# 1255 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2761!$omp target update to(buff_recv)
2762# 1255 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2763#endif
2764# 1256 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2765 call nvtxendrange
2766# 1258 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2767 end if
2768# 1232 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2769 if (use_rdma_transport .eqv. .true.) then
2770# 1233 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2771# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2772
2773# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2774#if defined(MFC_OpenACC)
2775# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2776!$acc host_data use_device(buff_send, buff_recv)
2777# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2778 call nvtxstartrange("BETA-COMM-SENDRECV-RDMA")
2779# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2780
2781# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2782 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
2783# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2784 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
2785# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2786
2787# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2788 call nvtxendrange ! BETA-MPI-SENDRECV-(NO)-RDMA
2789# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2790!$acc end host_data
2791# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2792#elif defined(MFC_OpenMP)
2793# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2794!$omp target data use_device_addr(buff_send, buff_recv)
2795# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2796 call nvtxstartrange("BETA-COMM-SENDRECV-RDMA")
2797# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2798
2799# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2800 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
2801# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2802 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
2803# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2804
2805# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2806 call nvtxendrange ! BETA-MPI-SENDRECV-(NO)-RDMA
2807# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2808!$omp end target data
2809# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2810#else
2811# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2812 call nvtxstartrange("BETA-COMM-SENDRECV-RDMA")
2813# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2814
2815# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2816 call mpi_sendrecv(buff_send, buffer_count, mpi_p, dst_proc, send_tag, buff_recv, buffer_count, mpi_p, &
2817# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2818 & src_proc, recv_tag, mpi_comm_world, mpi_status_ignore, ierr)
2819# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2820
2821# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2822 call nvtxendrange ! BETA-MPI-SENDRECV-(NO)-RDMA
2823# 1234 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2824#endif
2825# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2826
2827# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2828#if defined(MFC_OpenACC)
2829# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2830!$acc wait
2831# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2832#elif defined(MFC_OpenMP)
2833# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2834!$omp barrier
2835# 1242 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2836#endif
2837# 1243 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2838# 1258 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2839 end if
2840# 1260 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2841
2842 ! Unpack Received Buffer (skip if no source rank)
2843 call nvtxstartrange("BETA-COMM-UNPACKBUF")
2844 if (src_proc /= mpi_proc_null) then
2845# 1265 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2846 if (mpi_dir == 1) then
2847# 1266 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2848# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2849
2850# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2851
2852# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2853#if defined(MFC_OpenACC)
2854# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2855!$acc parallel loop collapse(4) gang vector default(present) private(r, y_kahan, t_kahan) copyin(replace_buff)
2856# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2857#elif defined(MFC_OpenMP)
2858# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2859
2860# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2861
2862# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2863
2864# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2865!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) &
2866# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2867!$omp& private(r, y_kahan, t_kahan) map(to:replace_buff)
2868# 1267 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2869#endif
2870# 1268 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2871 do l = comm_coords(3)%beg, comm_coords(3)%end
2872 do k = comm_coords(2)%beg, comm_coords(2)%end
2873 do j = -mapcells - 1, mapcells
2874 do i = 1, v_size
2875 r = (i - 1) + v_size*((j + mapcells + 1) + lb_size*((k - comm_coords(2)%beg) &
2876 & + comm_size(2)*(l - comm_coords(3)%beg)))
2877 if (replace_buff) then
2878 q_comm(beta_vars(i))%sf(j + unpack_offset, k, l) = real(buff_recv(r), kind=stp)
2879 kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, &
2880 & l) = real(q_comm(beta_vars(i))%sf(j + unpack_offset, k, l), &
2881 & kind=wp) - buff_recv(r)
2882 else
2883 y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, l), &
2884 & kind=wp)
2885 t_kahan = real(q_comm(beta_vars(i))%sf(j + unpack_offset, k, l), kind=wp) + y_kahan
2886 kahan_comp(beta_vars(i))%sf(j + unpack_offset, k, &
2887 & l) = (t_kahan - q_comm(beta_vars(i))%sf(j + unpack_offset, k, l)) - y_kahan
2888 q_comm(beta_vars(i))%sf(j + unpack_offset, k, l) = t_kahan
2889 end if
2890 end do
2891 end do
2892 end do
2893 end do
2894
2895# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2896#if defined(MFC_OpenACC)
2897# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2898!$acc end parallel loop
2899# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2900#elif defined(MFC_OpenMP)
2901# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2902
2903# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2904!$omp end target teams loop
2905# 1291 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2906#endif
2907# 1292 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2908# 1346 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2909 end if
2910# 1265 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2911 if (mpi_dir == 2) then
2912# 1266 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2913# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2914
2915# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2916
2917# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2918#if defined(MFC_OpenACC)
2919# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2920!$acc parallel loop collapse(4) gang vector default(present) private(r, y_kahan, t_kahan) copyin(replace_buff)
2921# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2922#elif defined(MFC_OpenMP)
2923# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2924
2925# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2926
2927# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2928
2929# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2930!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) &
2931# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2932!$omp& private(r, y_kahan, t_kahan) map(to:replace_buff)
2933# 1293 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2934#endif
2935# 1294 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2936 do i = 1, v_size
2937 do l = comm_coords(3)%beg, comm_coords(3)%end
2938 do k = -mapcells - 1, mapcells
2939 do j = comm_coords(1)%beg, comm_coords(1)%end
2940 r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k + mapcells + 1) &
2941 & + lb_size*(l - comm_coords(3)%beg)))
2942 if (replace_buff) then
2943 q_comm(beta_vars(i))%sf(j, k + unpack_offset, l) = real(buff_recv(r), kind=stp)
2944 kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, &
2945 & l) = real(q_comm(beta_vars(i))%sf(j, k + unpack_offset, l), &
2946 & kind=wp) - buff_recv(r)
2947 else
2948 y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, l), &
2949 & kind=wp)
2950 t_kahan = real(q_comm(beta_vars(i))%sf(j, k + unpack_offset, l), kind=wp) + y_kahan
2951 kahan_comp(beta_vars(i))%sf(j, k + unpack_offset, &
2952 & l) = (t_kahan - q_comm(beta_vars(i))%sf(j, k + unpack_offset, l)) - y_kahan
2953 q_comm(beta_vars(i))%sf(j, k + unpack_offset, l) = t_kahan
2954 end if
2955 end do
2956 end do
2957 end do
2958 end do
2959
2960# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2961#if defined(MFC_OpenACC)
2962# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2963!$acc end parallel loop
2964# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2965#elif defined(MFC_OpenMP)
2966# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2967
2968# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2969!$omp end target teams loop
2970# 1317 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2971#endif
2972# 1318 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2973# 1346 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2974 end if
2975# 1265 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2976 if (mpi_dir == 3) then
2977# 1266 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2978# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2979
2980# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2981
2982# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2983#if defined(MFC_OpenACC)
2984# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2985!$acc parallel loop collapse(4) gang vector default(present) private(r, y_kahan, t_kahan) copyin(replace_buff)
2986# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2987#elif defined(MFC_OpenMP)
2988# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2989
2990# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2991
2992# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2993
2994# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2995!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) &
2996# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2997!$omp& private(r, y_kahan, t_kahan) map(to:replace_buff)
2998# 1319 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
2999#endif
3000# 1320 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3001 do i = 1, v_size
3002 do l = -mapcells - 1, mapcells
3003 do k = comm_coords(2)%beg, comm_coords(2)%end
3004 do j = comm_coords(1)%beg, comm_coords(1)%end
3005 r = (i - 1) + v_size*((j - comm_coords(1)%beg) + comm_size(1)*((k - comm_coords(2)%beg) &
3006 & + comm_size(2)*(l + mapcells + 1)))
3007 if (replace_buff) then
3008 q_comm(beta_vars(i))%sf(j, k, l + unpack_offset) = real(buff_recv(r), kind=stp)
3009 kahan_comp(beta_vars(i))%sf(j, k, &
3010 & l + unpack_offset) = real(q_comm(beta_vars(i))%sf(j, k, &
3011 & l + unpack_offset), kind=wp) - buff_recv(r)
3012 else
3013 y_kahan = buff_recv(r) - real(kahan_comp(beta_vars(i))%sf(j, k, l + unpack_offset), &
3014 & kind=wp)
3015 t_kahan = real(q_comm(beta_vars(i))%sf(j, k, l + unpack_offset), kind=wp) + y_kahan
3016 kahan_comp(beta_vars(i))%sf(j, k, &
3017 & l + unpack_offset) = (t_kahan - q_comm(beta_vars(i))%sf(j, k, &
3018 & l + unpack_offset)) - y_kahan
3019 q_comm(beta_vars(i))%sf(j, k, l + unpack_offset) = t_kahan
3020 end if
3021 end do
3022 end do
3023 end do
3024 end do
3025
3026# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3027#if defined(MFC_OpenACC)
3028# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3029!$acc end parallel loop
3030# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3031#elif defined(MFC_OpenMP)
3032# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3033
3034# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3035!$omp end target teams loop
3036# 1344 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3037#endif
3038# 1345 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3039# 1346 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3040 end if
3041# 1348 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3042 end if
3043 call nvtxendrange
3044#endif
3045
3046 end subroutine s_mpi_reduce_beta_variables_buffers
3047
3048 !> The purpose of this procedure is to optimally decompose the computational domain among the available processors. This is
3049 !! performed by attempting to award each processor, in each of the coordinate directions, approximately the same number of
3050 !! cells, and then recomputing the affected global parameters.
3051 subroutine s_mpi_decompose_computational_domain(write_silo_ghost_offsets, adjust_local_domains, output_offsets, local_domains)
3052
3053 logical, intent(in) :: write_silo_ghost_offsets
3054 logical, intent(in) :: adjust_local_domains
3055 type(int_bounds_info), dimension(3), intent(inout), optional :: output_offsets
3056 type(bounds_info), dimension(3), intent(inout), optional :: local_domains
3057
3058#ifdef MFC_MPI
3059 !> Non-optimal number of processors in the x-, y- and z-directions
3060 real(wp) :: tmp_num_procs_x, tmp_num_procs_y, tmp_num_procs_z
3061 real(wp) :: fct_min !< Processor factorization (fct) minimization parameter
3062 integer :: MPI_COMM_CART !< Cartesian processor topology communicator
3063 integer :: rem_cells !< Remaining cells after distribution among processors
3064 integer :: rem_cells_by_dim(3)
3065 integer :: recon_order !< WENO or MUSCL reconstruction order
3066 integer :: i, j, k !< Generic loop iterators
3067 integer :: ierr !< Generic flag used to identify and report MPI errors
3068
3069 ! temp array to store neighbor rank coordinates
3070 integer, dimension(1:num_dims) :: neighbor_coords
3071
3072 rem_cells_by_dim = 0
3073
3074 ! Zeroing out communication needs for moving EL bubbles/particles
3075 nidx(1)%beg = 0; nidx(1)%end = 0
3076 nidx(2)%beg = 0; nidx(2)%end = 0
3077 nidx(3)%beg = 0; nidx(3)%end = 0
3078
3079 if (recon_type == recon_type_weno) then
3080 recon_order = weno_order
3081 else
3082 recon_order = muscl_order
3083 end if
3084
3085 if (num_procs == 1 .and. parallel_io) then
3086 do i = 1, num_dims
3087 start_idx(i) = 0
3088 end do
3089 return
3090 end if
3091
3092 if (igr) then
3093 recon_order = igr_order
3094 end if
3095
3096 ! 3D Cartesian Processor Topology
3097 if (n > 0) then
3098 if (p > 0) then
3099 if (fft_wrt) then
3100 ! Initial estimate of optimal processor topology
3101 num_procs_x = 1
3102 num_procs_y = 1
3103 num_procs_z = num_procs
3104 ierr = -1
3105
3106 ! Benchmarking the quality of this initial guess
3107 tmp_num_procs_y = num_procs_y
3108 tmp_num_procs_z = num_procs_z
3109 fct_min = 10._wp*abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z)
3110
3111 ! Optimization of the initial processor topology
3112 do i = 1, num_procs
3113 if (mod(num_procs, i) == 0 .and. (n + 1)/i >= num_stcls_min*recon_order) then
3114 tmp_num_procs_y = i
3115 tmp_num_procs_z = num_procs/i
3116
3117 if (fct_min >= abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z) .and. (p + 1) &
3118 & /tmp_num_procs_z >= num_stcls_min*recon_order) then
3119 num_procs_y = i
3120 num_procs_z = num_procs/i
3121 fct_min = abs((n + 1)/tmp_num_procs_y - (p + 1)/tmp_num_procs_z)
3122 ierr = 0
3123 end if
3124 end if
3125 end do
3126 else
3127 if (cyl_coord .and. p > 0) then
3128 ! Pencil blocking for cylindrical coordinates (Fourier filter near axis)
3129
3130 ! Initial values of the processor factorization optimization
3131 num_procs_x = 1
3132 num_procs_y = num_procs
3133 num_procs_z = 1
3134 ierr = -1
3135
3136 ! Computing minimization variable for these initial values
3137 tmp_num_procs_x = num_procs_x
3138 tmp_num_procs_y = num_procs_y
3139 tmp_num_procs_z = num_procs_z
3140 fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y)
3141
3142 ! Searching for optimal computational domain distribution
3143 do i = 1, num_procs
3144 if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then
3145 tmp_num_procs_x = i
3146 tmp_num_procs_y = num_procs/i
3147
3148 if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) .and. (n + 1) &
3149 & /tmp_num_procs_y >= num_stcls_min*recon_order) then
3150 num_procs_x = i
3151 num_procs_y = num_procs/i
3152 fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y)
3153 ierr = 0
3154 end if
3155 end if
3156 end do
3157 else
3158 ! Initial estimate of optimal processor topology
3159 num_procs_x = 1
3160 num_procs_y = 1
3161 num_procs_z = num_procs
3162 ierr = -1
3163
3164 ! Benchmarking the quality of this initial guess
3165 tmp_num_procs_x = num_procs_x
3166 tmp_num_procs_y = num_procs_y
3167 tmp_num_procs_z = num_procs_z
3168 fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + 10._wp*abs((n + 1) &
3169 & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z)
3170
3171 ! Optimization of the initial processor topology
3172 do i = 1, num_procs
3173 if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then
3174 do j = 1, num_procs/i
3175 if (mod(num_procs/i, j) == 0 .and. (n + 1)/j >= num_stcls_min*recon_order) then
3176 tmp_num_procs_x = i
3177 tmp_num_procs_y = j
3178 tmp_num_procs_z = num_procs/(i*j)
3179
3180 if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) &
3181 & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z) .and. (p + 1) &
3182 & /tmp_num_procs_z >= num_stcls_min*recon_order) then
3183 num_procs_x = i
3184 num_procs_y = j
3185 num_procs_z = num_procs/(i*j)
3186 fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) + abs((n + 1) &
3187 & /tmp_num_procs_y - (p + 1)/tmp_num_procs_z)
3188 ierr = 0
3189 end if
3190 end if
3191 end do
3192 end if
3193 end do
3194 end if
3195 end if
3196
3197 ! Verifying that a valid decomposition of the computational domain has been established. If not, the simulation
3198 ! exits.
3199 if (proc_rank == 0 .and. ierr == -1) then
3200 call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n, p and ' &
3201 & // 'weno/muscl/igr_order. Exiting.')
3202 end if
3203
3204 ! Creating new communicator using the Cartesian topology
3205 call mpi_cart_create(mpi_comm_world, 3, (/num_procs_x, num_procs_y, num_procs_z/), (/.true., .true., .true./), &
3206 & .false., mpi_comm_cart, ierr)
3207
3208 ! Finding the Cartesian coordinates of the local process
3209 call mpi_cart_coords(mpi_comm_cart, proc_rank, 3, proc_coords, ierr)
3210
3211 ! Global Parameters for z-direction
3212
3213 ! Number of remaining cells
3214 rem_cells = mod(p + 1, num_procs_z)
3215 rem_cells_by_dim(3) = rem_cells
3216
3217 ! Optimal number of cells per processor
3218 p = (p + 1)/num_procs_z - 1
3219
3220 ! Distributing the remaining cells
3221 do i = 1, rem_cells
3222 if (proc_coords(3) == i - 1) then
3223 p = p + 1; exit
3224 end if
3225 end do
3226
3227 ! Boundary condition at the beginning
3228 if (proc_coords(3) > 0 .or. (bc_z%beg == bc_periodic .and. num_procs_z > 1)) then
3229 proc_coords(3) = proc_coords(3) - 1
3230 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_z%beg, ierr)
3231 proc_coords(3) = proc_coords(3) + 1
3232 nidx(3)%beg = -1
3233 end if
3234
3235 ! Boundary condition at the end
3236 if (proc_coords(3) < num_procs_z - 1 .or. (bc_z%end == bc_periodic .and. num_procs_z > 1)) then
3237 proc_coords(3) = proc_coords(3) + 1
3238 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_z%end, ierr)
3239 proc_coords(3) = proc_coords(3) - 1
3240 nidx(3)%end = 1
3241 end if
3242
3243 ! Beginning and end sub-domain boundary locations
3244 if (parallel_io) then
3245 if (proc_coords(3) < rem_cells) then
3246 start_idx(3) = (p + 1)*proc_coords(3)
3247 else
3248 start_idx(3) = (p + 1)*proc_coords(3) + rem_cells
3249 end if
3250 end if
3251
3252 ! 2D Cartesian Processor Topology
3253 else
3254 ! Initial estimate of optimal processor topology
3255 num_procs_x = 1
3256 num_procs_y = num_procs
3257 ierr = -1
3258
3259 ! Benchmarking the quality of this initial guess
3260 tmp_num_procs_x = num_procs_x
3261 tmp_num_procs_y = num_procs_y
3262 fct_min = 10._wp*abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y)
3263
3264 ! Optimization of the initial processor topology
3265 do i = 1, num_procs
3266 if (mod(num_procs, i) == 0 .and. (m + 1)/i >= num_stcls_min*recon_order) then
3267 tmp_num_procs_x = i
3268 tmp_num_procs_y = num_procs/i
3269
3270 if (fct_min >= abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y) .and. (n + 1) &
3271 & /tmp_num_procs_y >= num_stcls_min*recon_order) then
3272 num_procs_x = i
3273 num_procs_y = num_procs/i
3274 fct_min = abs((m + 1)/tmp_num_procs_x - (n + 1)/tmp_num_procs_y)
3275 ierr = 0
3276 end if
3277 end if
3278 end do
3279
3280 ! Verifying that a valid decomposition of the computational domain has been established. If not, the simulation
3281 ! exits.
3282 if (proc_rank == 0 .and. ierr == -1) then
3283 call s_mpi_abort('Unsupported combination of values ' // 'of num_procs, m, n and ' &
3284 & // 'weno/muscl/igr_order. Exiting.')
3285 end if
3286
3287 ! Creating new communicator using the Cartesian topology
3288 call mpi_cart_create(mpi_comm_world, 2, (/num_procs_x, num_procs_y/), (/.true., .true./), .false., mpi_comm_cart, &
3289 & ierr)
3290
3291 ! Finding the Cartesian coordinates of the local process
3292 call mpi_cart_coords(mpi_comm_cart, proc_rank, 2, proc_coords, ierr)
3293 end if
3294
3295 ! Global Parameters for y-direction
3296
3297 ! Number of remaining cells
3298 rem_cells = mod(n + 1, num_procs_y)
3299 rem_cells_by_dim(2) = rem_cells
3300
3301 ! Optimal number of cells per processor
3302 n = (n + 1)/num_procs_y - 1
3303
3304 ! Distributing the remaining cells
3305 do i = 1, rem_cells
3306 if (proc_coords(2) == i - 1) then
3307 n = n + 1; exit
3308 end if
3309 end do
3310
3311 ! Boundary condition at the beginning
3312 if (proc_coords(2) > 0 .or. (bc_y%beg == bc_periodic .and. num_procs_y > 1)) then
3313 proc_coords(2) = proc_coords(2) - 1
3314 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_y%beg, ierr)
3315 proc_coords(2) = proc_coords(2) + 1
3316 nidx(2)%beg = -1
3317 end if
3318
3319 ! Boundary condition at the end
3320 if (proc_coords(2) < num_procs_y - 1 .or. (bc_y%end == bc_periodic .and. num_procs_y > 1)) then
3321 proc_coords(2) = proc_coords(2) + 1
3322 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_y%end, ierr)
3323 proc_coords(2) = proc_coords(2) - 1
3324 nidx(2)%end = 1
3325 end if
3326
3327 ! Beginning and end sub-domain boundary locations
3328 if (parallel_io) then
3329 if (proc_coords(2) < rem_cells) then
3330 start_idx(2) = (n + 1)*proc_coords(2)
3331 else
3332 start_idx(2) = (n + 1)*proc_coords(2) + rem_cells
3333 end if
3334 end if
3335
3336 ! 1D Cartesian Processor Topology
3337 else
3338 ! Optimal processor topology
3339 num_procs_x = num_procs
3340
3341 ! Creating new communicator using the Cartesian topology
3342 call mpi_cart_create(mpi_comm_world, 1, (/num_procs_x/), (/.true./), .false., mpi_comm_cart, ierr)
3343
3344 ! Finding the Cartesian coordinates of the local process
3345 call mpi_cart_coords(mpi_comm_cart, proc_rank, 1, proc_coords, ierr)
3346 end if
3347
3348 ! Global Parameters for x-direction
3349
3350 ! Number of remaining cells
3351 rem_cells = mod(m + 1, num_procs_x)
3352 rem_cells_by_dim(1) = rem_cells
3353
3354 ! Optimal number of cells per processor
3355 m = (m + 1)/num_procs_x - 1
3356
3357 ! Distributing the remaining cells
3358 do i = 1, rem_cells
3359 if (proc_coords(1) == i - 1) then
3360 m = m + 1; exit
3361 end if
3362 end do
3363
3364 call s_update_cell_bounds(cells_bounds, m, n, p)
3365
3366 ! Boundary condition at the beginning
3367 if (proc_coords(1) > 0 .or. (bc_x%beg == bc_periodic .and. num_procs_x > 1)) then
3368 proc_coords(1) = proc_coords(1) - 1
3369 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_x%beg, ierr)
3370 proc_coords(1) = proc_coords(1) + 1
3371 nidx(1)%beg = -1
3372 end if
3373
3374 ! Boundary condition at the end
3375 if (proc_coords(1) < num_procs_x - 1 .or. (bc_x%end == bc_periodic .and. num_procs_x > 1)) then
3376 proc_coords(1) = proc_coords(1) + 1
3377 call mpi_cart_rank(mpi_comm_cart, proc_coords, bc_x%end, ierr)
3378 proc_coords(1) = proc_coords(1) - 1
3379 nidx(1)%end = 1
3380 end if
3381
3382 ! Beginning and end sub-domain boundary locations
3383 if (parallel_io) then
3384 if (proc_coords(1) < rem_cells) then
3385 start_idx(1) = (m + 1)*proc_coords(1)
3386 else
3387 start_idx(1) = (m + 1)*proc_coords(1) + rem_cells
3388 end if
3389 end if
3390
3391 call s_apply_decomposition_policies((/num_procs_x, num_procs_y, num_procs_z/), rem_cells_by_dim, (/m, n, p/), (/m_glb, &
3392 & n_glb, p_glb/), write_silo_ghost_offsets, &
3393 & adjust_local_domains .and. (.not. parallel_io), output_offsets, local_domains)
3394
3395#ifdef MFC_DEBUG
3396# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3397 block
3398# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3399 use iso_fortran_env, only: output_unit
3400# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3401
3402# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3403 print *, 'm_mpi_common.fpp:1701: ', '@:ALLOCATE(neighbor_ranks(nidx(1)%beg:nidx(1)%end, nidx(2)%beg:nidx(2)%end, nidx(3)%beg:nidx(3)%end))'
3404# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3405
3406# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3407 call flush (output_unit)
3408# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3409 end block
3410# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3411#endif
3412# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3413 allocate (neighbor_ranks(nidx(1)%beg:nidx(1)%end, nidx(2)%beg:nidx(2)%end, nidx(3)%beg:nidx(3)%end))
3414# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3415
3416# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3417
3418# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3419#if defined(MFC_OpenACC)
3420# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3421!$acc enter data create(neighbor_ranks)
3422# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3423#elif defined(MFC_OpenMP)
3424# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3425!$omp target enter data map(always,alloc:neighbor_ranks)
3426# 1701 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3427#endif
3428# 1702 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3429 do k = nidx(3)%beg, nidx(3)%end
3430 do j = nidx(2)%beg, nidx(2)%end
3431 do i = nidx(1)%beg, nidx(1)%end
3432 if (abs(i) + abs(j) + abs(k) > 0) then
3433 neighbor_coords(1) = proc_coords(1) + i
3434 if (num_dims > 1) neighbor_coords(2) = proc_coords(2) + j
3435 if (num_dims > 2) neighbor_coords(3) = proc_coords(3) + k
3436 call mpi_cart_rank(mpi_comm_cart, neighbor_coords, neighbor_ranks(i, j, k), ierr)
3437 end if
3438 end do
3439 end do
3440 end do
3441#endif
3442
3443 end subroutine s_mpi_decompose_computational_domain
3444
3445 !> Apply executable-configured output and local-domain policies after the shared Cartesian decomposition.
3446 subroutine s_apply_decomposition_policies(proc_counts, remainders, local_cells, global_cells, write_silo_ghost_offsets, &
3447 & adjust_local_domains, output_offsets, local_domains)
3448
3449 integer, dimension(3), intent(in) :: proc_counts, remainders, local_cells, global_cells
3450 logical, intent(in) :: write_silo_ghost_offsets, adjust_local_domains
3451 type(int_bounds_info), dimension(3), intent(inout), optional :: output_offsets
3452 type(bounds_info), dimension(3), intent(inout), optional :: local_domains
3453 integer :: dim
3454 real(wp) :: domain_beg, domain_end, spacing
3455
3456 if (write_silo_ghost_offsets .and. .not. present(output_offsets)) then
3457 call s_mpi_abort('Silo ghost-offset policy requires output offset storage.')
3458 end if
3459 if (adjust_local_domains .and. .not. present(local_domains)) then
3460 call s_mpi_abort('Local-domain adjustment policy requires domain storage.')
3461 end if
3462
3463 if (present(output_offsets)) then
3464 do dim = 1, 3
3465 output_offsets(dim)%beg = 0
3466 output_offsets(dim)%end = 0
3467 end do
3468
3469 if (write_silo_ghost_offsets) then
3470 do dim = 1, num_dims
3471 if (proc_coords(dim) > 0) output_offsets(dim)%beg = 2
3472 if (proc_coords(dim) < proc_counts(dim) - 1) output_offsets(dim)%end = 2
3473 end do
3474 end if
3475 end if
3476
3477 if (adjust_local_domains) then
3478 do dim = 1, num_dims
3479 domain_beg = local_domains(dim)%beg
3480 domain_end = local_domains(dim)%end
3481 spacing = (domain_end - domain_beg)/real(global_cells(dim) + 1, wp)
3482
3483 select case (dim)
3484 case (1)
3485 dx_min = spacing
3486 case (2)
3487 dy_min = spacing
3488 case (3)
3489 dz_min = spacing
3490 end select
3491
3492 if (proc_coords(dim) < remainders(dim)) then
3493 local_domains(dim)%beg = domain_beg + spacing*real((local_cells(dim) + 1)*proc_coords(dim), wp)
3494 local_domains(dim)%end = domain_end - spacing*real((local_cells(dim) + 1)*(proc_counts(dim) - proc_coords(dim) &
3495 & - 1) - (proc_counts(dim) - remainders(dim)), wp)
3496 else
3497 local_domains(dim)%beg = domain_beg + spacing*real((local_cells(dim) + 1)*proc_coords(dim) + remainders(dim), &
3498 & wp)
3499 local_domains(dim)%end = domain_end - spacing*real((local_cells(dim) + 1)*(proc_counts(dim) - proc_coords(dim) &
3500 & - 1), wp)
3501 end if
3502 end do
3503 end if
3504
3505 end subroutine s_apply_decomposition_policies
3506
3507 !> The goal of this procedure is to populate the buffers of the grid variables by communicating with the neighboring processors.
3508 !! Note that only the buffers of the cell-width distributions are handled in such a way. This is because the buffers of
3509 !! cell-boundary locations may be calculated directly from those of the cell-width distributions.
3510 subroutine s_mpi_sendrecv_grid_variable_buffer(cell_boundaries, cell_centers, cell_widths, num_cells, bc_bounds, pbc_loc, &
3511 & offset)
3512
3513 integer, intent(in) :: num_cells, pbc_loc
3514 type(int_bounds_info), intent(in) :: bc_bounds, offset
3515 ! Contiguous so that passing an element to MPI is a plain address, with no descriptor
3516 ! or copy-in/copy-out. Every actual argument is a whole module array. The attribute must
3517 ! be on ALL THREE, and on every frame that forwards them: CCE 19 IPA drops the stores to
3518 ! the non-contiguous dummies when one call mixes contiguous and non-contiguous arrays.
3519 real(wp), contiguous, intent(inout) :: cell_boundaries(-1 - offset%beg:)
3520 real(wp), contiguous, intent(inout) :: cell_centers(-buff_size:)
3521 real(wp), contiguous, intent(inout) :: cell_widths(-buff_size:)
3522
3523#ifdef MFC_MPI
3524 integer :: ierr
3525 integer :: i
3526
3527 if (pbc_loc == -1) then
3528 if (bc_bounds%end >= 0) then
3529 call mpi_sendrecv(cell_widths(num_cells - buff_size + 1), buff_size, mpi_p, bc_bounds%end, 0, &
3530 & cell_widths(-buff_size), buff_size, mpi_p, bc_bounds%beg, 0, mpi_comm_world, &
3531 & mpi_status_ignore, ierr)
3532 else
3533 call mpi_sendrecv(cell_widths(0), buff_size, mpi_p, bc_bounds%beg, 1, cell_widths(-buff_size), buff_size, mpi_p, &
3534 & bc_bounds%beg, 0, mpi_comm_world, mpi_status_ignore, ierr)
3535 end if
3536 do i = 1, offset%beg
3537 cell_boundaries(-1 - i) = cell_boundaries(-i) - cell_widths(-i)
3538 end do
3539 do i = 1, buff_size
3540 cell_centers(-i) = cell_centers(1 - i) - (cell_widths(1 - i) + cell_widths(-i))/2._wp
3541 end do
3542 else
3543 if (bc_bounds%beg >= 0) then
3544 call mpi_sendrecv(cell_widths(0), buff_size, mpi_p, bc_bounds%beg, 1, cell_widths(num_cells + 1), buff_size, &
3545 & mpi_p, bc_bounds%end, 1, mpi_comm_world, mpi_status_ignore, ierr)
3546 else
3547 call mpi_sendrecv(cell_widths(num_cells - buff_size + 1), buff_size, mpi_p, bc_bounds%end, 0, &
3548 & cell_widths(num_cells + 1), buff_size, mpi_p, bc_bounds%end, 1, mpi_comm_world, &
3549 & mpi_status_ignore, ierr)
3550 end if
3551 do i = 1, offset%end
3552 cell_boundaries(num_cells + i) = cell_boundaries(num_cells + i - 1) + cell_widths(num_cells + i)
3553 end do
3554 do i = 1, buff_size
3555 cell_centers(num_cells + i) = cell_centers(num_cells + i - 1) + (cell_widths(num_cells + i - 1) &
3556 & + cell_widths(num_cells + i))/2._wp
3557 end do
3558 end if
3559#endif
3560
3561 end subroutine s_mpi_sendrecv_grid_variable_buffer
3562
3563 !> Populate the local cell-boundary, cell-center, and cell-width arrays in one direction directly from the global cell-boundary
3564 !! array. This guarantees that every rank sees bitwise-identical values at any shared physical cell or boundary
3565 subroutine s_apply_grid_from_global_dim(x_cb_glb, m_dim_glb, m_dim, sidx, bc_beg, bc_end, cb_lo, cb_hi, cw_lo, cw_hi, &
3566 & x_cb_loc, x_cc_loc, dx_loc)
3567
3568 integer, intent(in) :: m_dim_glb, m_dim, sidx, bc_beg, bc_end
3569 integer, intent(in) :: cb_lo, cb_hi, cw_lo, cw_hi
3570 real(wp), intent(in) :: x_cb_glb(-1:m_dim_glb)
3571 real(wp), intent(inout) :: x_cb_loc(-1 - cb_lo:m_dim + cb_hi)
3572 real(wp), intent(inout) :: x_cc_loc(-cw_lo:m_dim + cw_hi)
3573 real(wp), intent(inout) :: dx_loc(-cw_lo:m_dim + cw_hi)
3574 real(wp) :: domain_len
3575 integer :: i, gidx, lo, hi
3576
3577 domain_len = x_cb_glb(m_dim_glb) - x_cb_glb(-1)
3578
3579 ! Interior cell boundaries sliced directly from the global list
3580 do i = -1, m_dim
3581 x_cb_loc(i) = x_cb_glb(sidx + i)
3582 end do
3583
3584 ! Left ghost cell boundaries
3585 if (bc_beg >= 0) then
3586 if (sidx == 0) then
3587 ! Leftmost rank with a neighbor -> periodic+multirank, so wrap from the global right end
3588 do i = 1, cb_lo
3589 x_cb_loc(-1 - i) = x_cb_glb(m_dim_glb - i) - domain_len
3590 end do
3591 else
3592 do i = 1, cb_lo
3593 gidx = sidx - 1 - i
3594 if (gidx >= -1) then
3595 x_cb_loc(-1 - i) = x_cb_glb(gidx)
3596 else
3597 x_cb_loc(-1 - i) = x_cb_glb(m_dim_glb + 1 + gidx) - domain_len
3598 end if
3599 end do
3600 end if
3601 end if
3602
3603 ! Right ghost cell boundaries
3604 if (bc_end >= 0) then
3605 if (sidx + m_dim == m_dim_glb) then
3606 ! Rightmost rank with a neighbor -> periodic+multirank, wrap from the global left end
3607 do i = 1, cb_hi
3608 x_cb_loc(m_dim + i) = x_cb_glb(i - 1) + domain_len
3609 end do
3610 else
3611 do i = 1, cb_hi
3612 gidx = sidx + m_dim + i
3613 if (gidx <= m_dim_glb) then
3614 x_cb_loc(m_dim + i) = x_cb_glb(gidx)
3615 else
3616 x_cb_loc(m_dim + i) = x_cb_glb(gidx - m_dim_glb - 1) + domain_len
3617 end if
3618 end do
3619 end if
3620 end if
3621
3622 ! Recompute dx and x_cc over the range where x_cb is now valid using one formula so values are bitwise-identical
3623 if (bc_beg >= 0) then
3624 lo = -min(cw_lo, cb_lo)
3625 else
3626 lo = 0
3627 end if
3628
3629 if (bc_end >= 0) then
3630 hi = m_dim + min(cw_hi, cb_hi)
3631 else
3632 hi = m_dim
3633 end if
3634
3635 do i = lo, hi
3636 dx_loc(i) = x_cb_loc(i) - x_cb_loc(i - 1)
3637 x_cc_loc(i) = (x_cb_loc(i) + x_cb_loc(i - 1))/2._wp
3638 end do
3639
3640 end subroutine s_apply_grid_from_global_dim
3641
3642 !> Module deallocation and/or disassociation procedures
3643 impure subroutine s_finalize_mpi_common_module
3644
3645#ifdef MFC_MPI
3646#ifndef __NVCOMPILER_GPU_UNIFIED_MEM
3647#ifdef MFC_DEBUG
3648# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3649 block
3650# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3651 use iso_fortran_env, only: output_unit
3652# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3653
3654# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3655 print *, 'm_mpi_common.fpp:1920: ', '@:DEALLOCATE(buff_send, buff_recv)'
3656# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3657
3658# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3659 call flush (output_unit)
3660# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3661 end block
3662# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3663#endif
3664# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3665
3666# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3667#if defined(MFC_OpenACC)
3668# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3669!$acc exit data delete(buff_send, buff_recv)
3670# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3671#elif defined(MFC_OpenMP)
3672# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3673!$omp target exit data map(release:buff_send, buff_recv)
3674# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3675#endif
3676# 1920 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3677 deallocate (buff_send, buff_recv)
3678# 1921 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3679#else
3680
3681# 1922 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3682#if defined(MFC_OpenACC)
3683# 1922 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3684!$acc exit data delete(buff_send, buff_recv)
3685# 1922 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3686#elif defined(MFC_OpenMP)
3687# 1922 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3688!$omp target exit data map(release:buff_send, buff_recv)
3689# 1922 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3690#endif
3691# 1923 "/home/runner/work/MFC/MFC/src/common/m_mpi_common.fpp"
3692 deallocate (buff_send, buff_recv)
3693#endif
3694#endif
3695
3696 end subroutine s_finalize_mpi_common_module
3697
3698end module m_mpi_common
q_cons_vf
type(scalar_field), dimension(sys_size), intent(inout) q_cons_vf
Definition m_phase_change.fpp.f90:1041
k
integer, intent(in) k
Definition m_phase_change.fpp.f90:1043
j
integer, intent(in) j
Definition m_phase_change.fpp.f90:1043
m_constants
Compile-time constant parameters: default values, tolerances, and physical constants.
Definition m_constants.fpp.f90:7
m_constants::nnode
integer, parameter nnode
Number of QBMM nodes.
Definition m_constants.fpp.f90:46
m_constants::recon_type_weno
integer, parameter recon_type_weno
Definition m_constants.fpp.f90:167
m_derived_types
Shared derived types for field data, patch geometry, bubble dynamics, and MPI I/O structures.
Definition m_derived_types.fpp.f90:356
m_global_parameters
Defines global parameters for the computational domain, simulation algorithm, and initial conditions.
Definition m_global_parameters.fpp.f90:19
m_global_parameters::buff_size
integer buff_size
Number of ghost cells for boundary condition storage.
Definition m_global_parameters.fpp.f90:117
m_global_parameters::chem_params
type(chemistry_parameters) chem_params
Definition m_global_parameters.fpp.f90:90
m_global_parameters::cells_bounds
type(cell_num_bounds) cells_bounds
Definition m_global_parameters.fpp.f90:42
m_helper
Utility routines for bubble model setup, coordinate transforms, array sampling, and special functions...
Definition m_helper.fpp.f90:367
m_mpi_common
MPI communication layer: domain decomposition, halo exchange, reductions, and parallel I/O setup.
Definition m_mpi_common.fpp.f90:367
m_mpi_common::s_mpi_abort
impure subroutine s_mpi_abort(prnt, code)
The subroutine terminates the MPI execution environment.
Definition m_mpi_common.fpp.f90:1007
m_mpi_common::s_mpi_gather_data
impure subroutine s_mpi_gather_data(my_vector, counts, gathered_vector, root)
Gather variable-length real vectors from all MPI ranks onto the root process.
Definition m_mpi_common.fpp.f90:736
m_mpi_common::s_mpi_barrier
impure subroutine s_mpi_barrier
Halts all processes until all have reached barrier.
Definition m_mpi_common.fpp.f90:1056
m_mpi_common::s_mpi_initialize
impure subroutine s_mpi_initialize
Initialize the MPI execution environment and query the number of processors and local rank.
Definition m_mpi_common.fpp.f90:580
m_mpi_common::s_mpi_allreduce_vectors_sum
impure subroutine s_mpi_allreduce_vectors_sum(var_loc, var_glb, num_vectors, vector_length)
Reduce an array of vectors to their global sums across all MPI ranks.
Definition m_mpi_common.fpp.f90:874
m_mpi_common::buff_recv
real(wp), dimension(:), allocatable, private buff_recv
Primitive variable receive buffer for halo exchange Variables for EL bubbles communication.
Definition m_mpi_common.fpp.f90:400
m_mpi_common::s_mpi_reduce_maxloc
impure subroutine s_mpi_reduce_maxloc(var_loc)
Reduce a 2-element variable to its global maximum value with the owning processor rank (MPI_MAXLOC)....
Definition m_mpi_common.fpp.f90:990
m_mpi_common::beta_vars
integer, dimension(1:3) beta_vars
q_beta indices to communicate: 1=void fraction, 2=d(beta)/dt, 5=energy source
Definition m_mpi_common.fpp.f90:404
m_mpi_common::s_mpi_allreduce_sum
impure subroutine s_mpi_allreduce_sum(var_loc, var_glb)
Reduce a local real value to its global sum across all MPI ranks.
Definition m_mpi_common.fpp.f90:860
m_mpi_common::buff_send
real(wp), dimension(:), allocatable, private buff_send
Primitive variable send buffer for halo exchange.
Definition m_mpi_common.fpp.f90:398
m_mpi_common::s_mpi_allreduce_min
impure subroutine s_mpi_allreduce_min(var_loc, var_glb)
Reduce a local real value to its global minimum across all MPI ranks.
Definition m_mpi_common.fpp.f90:927
m_mpi_common::s_mpi_reduce_int_sum
subroutine s_mpi_reduce_int_sum(var_loc, sum)
Reduce a local integer value to its global sum across all MPI ranks.
Definition m_mpi_common.fpp.f90:844
m_mpi_common::s_check_mpi_file_open
impure subroutine s_check_mpi_file_open(ierr, file_loc)
Abort naming the file if MPI_FILE_OPEN failed. File errors default to MPI_ERRORS_RETURN,...
Definition m_mpi_common.fpp.f90:1039
m_mpi_common::s_prohibit_abort
impure subroutine s_prohibit_abort(condition, message)
Print a case file error with the prohibited condition and message, then abort execution.
Definition m_mpi_common.fpp.f90:780
m_mpi_common::s_mpi_finalize
impure subroutine s_mpi_finalize
The subroutine finalizes the MPI execution environment.
Definition m_mpi_common.fpp.f90:1067
m_mpi_common::s_apply_grid_from_global_dim
subroutine s_apply_grid_from_global_dim(x_cb_glb, m_dim_glb, m_dim, sidx, bc_beg, bc_end, cb_lo, cb_hi, cw_lo, cw_hi, x_cb_loc, x_cc_loc, dx_loc)
Populate the local cell-boundary, cell-center, and cell-width arrays in one direction directly from t...
Definition m_mpi_common.fpp.f90:3567
m_mpi_common::s_mpi_allreduce_max
impure subroutine s_mpi_allreduce_max(var_loc, var_glb)
Reduce a local real value to its global maximum across all MPI ranks.
Definition m_mpi_common.fpp.f90:957
m_mpi_common::s_mpi_allreduce_min_vec
impure subroutine s_mpi_allreduce_min_vec(var_loc, var_glb)
Reduce a local real vector to its elementwise global minimum across all MPI ranks.
Definition m_mpi_common.fpp.f90:941
m_mpi_common::s_mpi_allreduce_integer_sum
impure subroutine s_mpi_allreduce_integer_sum(var_loc, var_glb)
Reduce a local integer value to its global sum across all MPI ranks.
Definition m_mpi_common.fpp.f90:895
m_mpi_common::s_initialize_mpi_data
impure subroutine s_initialize_mpi_data(q_cons_vf, ib_markers, ib_mpi_data, beta, qbmm_pb, qbmm_mv)
Set up MPI I/O data views and variable pointers for parallel file output.
Definition m_mpi_common.fpp.f90:616
m_mpi_common::s_mpi_sendrecv_grid_variable_buffer
subroutine s_mpi_sendrecv_grid_variable_buffer(cell_boundaries, cell_centers, cell_widths, num_cells, bc_bounds, pbc_loc, offset)
The goal of this procedure is to populate the buffers of the grid variables by communicating with the...
Definition m_mpi_common.fpp.f90:3512
m_mpi_common::s_mpi_sendrecv_variables_buffers
subroutine s_mpi_sendrecv_variables_buffers(q_comm, mpi_dir, pbc_loc, nvar, pb_in, mv_in, q_t_sf)
The goal of this procedure is to populate the buffers of the cell-average conservative variables by c...
Definition m_mpi_common.fpp.f90:1079
m_mpi_common::v_size
integer, private v_size
Definition m_mpi_common.fpp.f90:384
m_mpi_common::s_mpi_decompose_computational_domain
subroutine s_mpi_decompose_computational_domain(write_silo_ghost_offsets, adjust_local_domains, output_offsets, local_domains)
The purpose of this procedure is to optimally decompose the computational domain among the available ...
Definition m_mpi_common.fpp.f90:3052
m_mpi_common::use_rdma_transport
logical, private use_rdma_transport
Definition m_mpi_common.fpp.f90:448
m_mpi_common::mpi_bcast_time_step_values
impure subroutine mpi_bcast_time_step_values(proc_time, time_avg)
Gather per-rank time step wall-clock times onto rank 0 for performance reporting.
Definition m_mpi_common.fpp.f90:766
m_mpi_common::s_mpi_reduce_min
impure subroutine s_mpi_reduce_min(var_loc)
Reduce a local real value to its global minimum across all ranks.
Definition m_mpi_common.fpp.f90:971
m_mpi_common::s_mpi_reduce_stability_criteria_extrema
impure subroutine s_mpi_reduce_stability_criteria_extrema(max_loc, min_loc, bubs_loc, max_glb, min_glb, bubs_glb)
The goal of this subroutine is to determine the global extrema of the stability criteria in the compu...
Definition m_mpi_common.fpp.f90:800
m_mpi_common::s_finalize_mpi_common_module
impure subroutine s_finalize_mpi_common_module
Module deallocation and/or disassociation procedures.
Definition m_mpi_common.fpp.f90:3644
m_mpi_common::comm_size
integer, dimension(3) comm_size
Definition m_mpi_common.fpp.f90:402
m_mpi_common::s_initialize_mpi_data_ds
subroutine s_initialize_mpi_data_ds(m_ds, n_ds, p_ds, q_cons_vf)
Set up MPI I/O data views for downsampled (coarsened) parallel file output.
Definition m_mpi_common.fpp.f90:699
m_mpi_common::s_mpi_reduce_beta_variables_buffers
subroutine s_mpi_reduce_beta_variables_buffers(q_comm, kahan_comp, mpi_dir, pbc_loc, nvar)
The goal of this procedure is to populate the buffers of the cell-average conservative variables by c...
Definition m_mpi_common.fpp.f90:2488
m_mpi_common::s_mpi_allreduce_integer_sum_vec
impure subroutine s_mpi_allreduce_integer_sum_vec(var_loc, var_glb)
Reduce an integer(8) array to its element-wise global sum across all MPI ranks.
Definition m_mpi_common.fpp.f90:911
m_mpi_common::comm_coords
type(int_bounds_info), dimension(3) comm_coords
Definition m_mpi_common.fpp.f90:401
m_mpi_common::exchange_all_chemistry_temperatures
logical, private exchange_all_chemistry_temperatures
Definition m_mpi_common.fpp.f90:447
m_mpi_common::s_apply_decomposition_policies
subroutine, private s_apply_decomposition_policies(proc_counts, remainders, local_cells, global_cells, write_silo_ghost_offsets, adjust_local_domains, output_offsets, local_domains)
Apply executable-configured output and local-domain policies after the shared Cartesian decomposition...
Definition m_mpi_common.fpp.f90:3448
m_mpi_common::halo_size
integer(kind=8) halo_size
Definition m_mpi_common.fpp.f90:433
m_mpi_common::s_initialize_mpi_common_module
impure subroutine s_initialize_mpi_common_module(exchange_all_chemistry_temperatures_in, use_rdma_transport_in)
Initialize the module.
Definition m_mpi_common.fpp.f90:454
m_nvtx
NVIDIA NVTX profiling API bindings for GPU performance instrumentation.
Definition m_nvtx.f90:6
m_derived_types::int_bounds_info
Integer bounds for variables.
Definition m_derived_types.fpp.f90:450