MFC
Exascale flow solver
Loading...
Searching...
No Matches
m_boundary_primitives.fpp.f90
Go to the documentation of this file.
1# 1 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2!>
3!! @file
4!! @brief Contains module m_boundary_primitives
5
6!> @brief Per-cell noncharacteristic boundary condition primitives applied in the ghost cells
7# 1 "/home/runner/work/MFC/MFC/src/common/include/case.fpp" 1
8! This file exists so that Fypp can be run without generating case.fpp files for
9! each target. This is useful when generating documentation, for example. This
10! should also let MFC be built with CMake directly, without invoking mfc.sh.
11
12! For pre-process.
13# 8 "/home/runner/work/MFC/MFC/src/common/include/case.fpp"
14
15! For moving immersed boundaries in simulation
16# 12 "/home/runner/work/MFC/MFC/src/common/include/case.fpp"
17# 7 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp" 2
18# 1 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 1
19# 1 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 1
20# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
21# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
22# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
23# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
24# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
25# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
26
27# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
28# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
29# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
30
31# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
32# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
33! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
34! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
35# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
36# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
37# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
38
39# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
40# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
41
42# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
43
44# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
45
46# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
47
48# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
49
50# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
51
52# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
53
54# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
55
56# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
57! New line at end of file is required for FYPP
58# 2 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
59# 1 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 1
60# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
61# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
62# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
63# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
64# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
65# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
66
67# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
68# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
69# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
70
71# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
72# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
73! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
74! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
75# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
76# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
77# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
78
79# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
80# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
81
82# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
83
84# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
85
86# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
87
88# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
89
90# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
91
92# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
93
94# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
95
96# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
97! New line at end of file is required for FYPP
98# 2 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 2
99
100# 4 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
101# 5 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
102# 6 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
103# 7 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
104# 8 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
105
106# 20 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
107
108# 43 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
109
110# 48 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
111
112# 53 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
113
114# 58 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
115
116# 63 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
117
118# 68 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
119
120# 81 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
121
122# 95 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
123
124# 100 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
125
126# 105 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
127
128# 110 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
129
130# 115 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
131
132# 120 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
133
134# 125 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
135
136# 130 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
137
138# 135 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
139
140# 165 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
141
142# 219 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
143
144# 233 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
145
146# 258 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
147
148# 269 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
149
150# 271 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
151# 282 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
152
153# 332 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
154
155# 342 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
156
157# 352 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
158
159# 361 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
160
161# 378 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
162
163# 388 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
164
165# 395 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
166
167# 401 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
168
169# 407 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
170
171# 413 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
172
173# 419 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
174
175# 425 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
176! New line at end of file is required for FYPP
177# 3 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
178# 1 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 1
179# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
180# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
181# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
182# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
183# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
184# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
185
186# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
187# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
188# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
189
190# 12 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
191# 1 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp" 1
192! Default for Fypp runs outside the toolchain (e.g. documentation). Searched last, so the
193! build/include/<target>/thermochem.fpp the toolchain writes from m_thermochem takes precedence.
194# 4 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
195# 5 "/home/runner/work/MFC/MFC/src/common/include/defaults/thermochem.fpp"
196# 13 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 2
197
198# 16 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
199# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
200
201# 24 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
202
203# 53 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
204
205# 65 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
206
207# 75 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
208
209# 105 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
210
211# 117 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
212
213# 127 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
214
215# 174 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
216! New line at end of file is required for FYPP
217# 2 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 2
218
219# 7 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
220
221# 17 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
222
223# 22 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
224
225# 27 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
226
227# 32 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
228
229# 37 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
230
231# 42 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
232
233# 47 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
234
235# 52 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
236
237# 57 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
238
239# 62 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
240
241# 73 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
242
243# 78 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
244
245# 83 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
246
247# 88 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
248
249# 103 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
250
251# 131 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
252
253# 160 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
254
255# 175 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
256
257# 193 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
258
259# 215 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
260
261# 244 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
262
263# 259 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
264
265# 269 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
266
267# 278 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
268
269# 294 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
270
271# 304 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
272
273# 311 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
274! New line at end of file is required for FYPP
275# 4 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
276
277! GPU parallel region (scalar reductions, maxval/minval)
278# 23 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
279
280! GPU parallel loop over threads (most common GPU macro)
281# 43 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
282
283! Required closing for GPU_PARALLEL_LOOP
284# 55 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
285
286! Mark routine for device compilation
287# 112 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
288
289! Declare device-resident data
290# 130 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
291
292! Inner loop within a GPU parallel region
293# 145 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
294
295! Scoped GPU data region
296# 164 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
297
298! Host code with device pointers (for MPI with GPU buffers)
299# 193 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
300
301! Allocate device memory (unscoped)
302# 207 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
303
304! Free device memory
305# 219 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
306
307! Atomic operation on device
308# 231 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
309
310! End atomic capture block
311# 242 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
312
313! Copy data between host and device
314# 254 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
315
316! Synchronization barrier
317# 266 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
318
319! Import GPU library module (openacc or omp_lib)
320# 275 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
321
322! Emit code only for AMD compiler
323# 282 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
324
325! Emit code for non-Cray compilers
326# 289 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
327
328! Emit code only for Cray compiler
329# 296 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
330
331! Emit code for non-NVIDIA compilers
332# 303 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
333
334# 305 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
335# 306 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
336! New line at end of file is required for FYPP
337# 2 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 2
338
339# 14 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
340
341! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI
342! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an
343! example see misc/nvidia_uvm/bind.sh.
344# 52 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
345
346! Allocate and create GPU device memory
347# 72 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
348
349! Free GPU device memory and deallocate
350# 80 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
351
352! Cray-specific GPU pointer setup for vector fields
353# 104 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
354
355! Cray-specific GPU pointer setup for scalar fields
356# 120 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
357
358! Cray-specific GPU pointer setup for acoustic source spatials
359# 145 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
360
361# 151 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
362
363# 158 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
364! New line at end of file is required for FYPP
365# 8 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp" 2
366
367module m_boundary_primitives
368
369 use m_derived_types
370 use m_global_parameters
371 use m_constants
372 use m_mpi_common
373
374 implicit none
375
376 type(scalar_field), dimension(:,:), allocatable :: bc_buffers
377
378# 19 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
379#if defined(MFC_OpenACC)
380# 19 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
381!$acc declare create(bc_buffers)
382# 19 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
383#elif defined(MFC_OpenMP)
384# 19 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
385!$omp declare target (bc_buffers)
386# 19 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
387#endif
388# 20 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
389
390 logical :: dirichlet_from_buffers = .false.
391
392# 22 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
393#if defined(MFC_OpenACC)
394# 22 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
395!$acc declare create(dirichlet_from_buffers)
396# 22 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
397#elif defined(MFC_OpenMP)
398# 22 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
399!$omp declare target (dirichlet_from_buffers)
400# 22 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
401#endif
402# 23 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
403
404 !> f_vel_ramp per direction, applied to Dirichlet ghost velocities; set by the time stepper when a ramp is active
405 real(wp), dimension(3) :: bc_vel_ramp = 1._wp
406
407# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
408#if defined(MFC_OpenACC)
409# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
410!$acc declare create(bc_vel_ramp)
411# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
412#elif defined(MFC_OpenMP)
413# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
414!$omp declare target (bc_vel_ramp)
415# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
416#endif
417# 27 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
418
419 public :: f_vel_ramp, bc_vel_ramp
420
421contains
422
423 !> Velocity scaling for a GRCBC inflow that is ramping up: unity unless `bc_[x,y,z]%vel_in_ramp` is set, so an unramped case is
424 !! untouched. Takes the time as an argument so the caller can evaluate it on the device from `mytime`, which the time stepper
425 !! already places there, rather than computing it on the host and copying the result every Runge-Kutta stage.
426 pure function f_vel_ramp(tau, t0, frac0, t) result(f)
427
428
429# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
430#if MFC_OpenACC
431# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
432!$acc routine seq
433# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
434#elif MFC_OpenMP
435# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
436
437# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
438
439# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
440!$omp declare target device_type(any)
441# 37 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
442#endif
443# 38 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
444 real(wp), intent(in) :: tau, t0, frac0, t
445 real(wp) :: f
446
447 if (tau > 0._wp) then
448 f = frac0 + (1._wp - frac0)*0.5_wp*(1._wp + tanh(6._wp*(t - t0)/tau - 3._wp))
449 else
450 f = 1._wp
451 end if
452
453 end function f_vel_ramp
454
455 !> Fill ghost cells by copying the nearest boundary cell value along the specified direction.
456 subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
457
458
459# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
460#ifdef _CRAYFTN
461# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
462#if MFC_OpenACC
463# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
464!$acc routine seq
465# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
466#elif MFC_OpenMP
467# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
468
469# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
470
471# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
472!$omp declare target device_type(any)
473# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
474#else
475# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
476!DIR$ INLINEALWAYS s_ghost_cell_extrapolation
477# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
478#endif
479# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
480#elif MFC_OpenACC
481# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
482!$acc routine seq
483# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
484#elif MFC_OpenMP
485# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
486
487# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
488
489# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
490!$omp declare target device_type(any)
491# 52 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
492#endif
493# 53 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
494 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
495 integer, intent(in) :: bc_dir, bc_loc
496 integer, intent(in) :: k, l
497 integer :: j, i
498 type(scalar_field), optional, intent(inout) :: q_T_sf
499
500 if (bc_dir == 1) then !< x-direction
501 if (bc_loc == -1) then ! bc_x%beg
502 do i = 1, sys_size
503 do j = 1, buff_size
504 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
505 end do
506 end do
507 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
508 do j = 1, buff_size
509 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
510 end do
511 end if
512 else !< bc_x%end
513 do i = 1, sys_size
514 do j = 1, buff_size
515 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
516 end do
517 end do
518 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
519 do j = 1, buff_size
520 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
521 end do
522 end if
523 end if
524 else if (bc_dir == 2) then !< y-direction
525 if (bc_loc == -1) then !< bc_y%beg
526 do i = 1, sys_size
527 do j = 1, buff_size
528 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
529 end do
530 end do
531
532 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
533 do j = 1, buff_size
534 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
535 end do
536 end if
537 else !< bc_y%end
538 do i = 1, sys_size
539 do j = 1, buff_size
540 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
541 end do
542 end do
543 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
544 do j = 1, buff_size
545 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
546 end do
547 end if
548 end if
549 else if (bc_dir == 3) then !< z-direction
550 if (bc_loc == -1) then !< bc_z%beg
551 do i = 1, sys_size
552 do j = 1, buff_size
553 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
554 end do
555 end do
556 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
557 do j = 1, buff_size
558 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, 0)
559 end do
560 end if
561 else !< bc_z%end
562 do i = 1, sys_size
563 do j = 1, buff_size
564 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
565 end do
566 end do
567 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
568 do j = 1, buff_size
569 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
570 end do
571 end if
572 end if
573 end if
574
575 end subroutine s_ghost_cell_extrapolation
576
577 !> Apply reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity component.
578 subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
579
580
581# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
582#if MFC_OpenACC
583# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
584!$acc routine seq
585# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
586#elif MFC_OpenMP
587# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
588
589# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
590
591# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
592!$omp declare target device_type(any)
593# 139 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
594#endif
595# 140 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
596 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
597 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
598 integer, intent(in) :: bc_dir, bc_loc
599 integer, intent(in) :: k, l
600 integer :: j, q, i
601 type(scalar_field), optional, intent(inout) :: q_T_sf
602
603 if (bc_dir == 1) then !< x-direction
604 if (bc_loc == -1) then !< bc_x%beg
605 do j = 1, buff_size
606 do i = 1, eqn_idx%cont%end
607 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
608 end do
609
610 q_prim_vf(eqn_idx%mom%beg)%sf(-j, k, l) = -q_prim_vf(eqn_idx%mom%beg)%sf(j - 1, k, l)
611
612 do i = eqn_idx%mom%beg + 1, sys_size
613 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
614 end do
615
616 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
617 q_t_sf%sf(-j, k, l) = q_t_sf%sf(j - 1, k, l)
618 end if
619
620 if (hypoelasticity) then
621 do i = 1, shear_bc_flip_num
622 q_prim_vf(shear_bc_flip_indices(1, i))%sf(-j, k, l) = -q_prim_vf(shear_bc_flip_indices(1, &
623 & i))%sf(j - 1, k, l)
624 end do
625 end if
626 end do
627
628 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
629 do i = 1, nb
630 do q = 1, nnode
631 do j = 1, buff_size
632 pb_in(-j, k, l, q, i) = pb_in(j - 1, k, l, q, i)
633 mv_in(-j, k, l, q, i) = mv_in(j - 1, k, l, q, i)
634 end do
635 end do
636 end do
637 end if
638 else !< bc_x%end
639 do j = 1, buff_size
640 do i = 1, eqn_idx%cont%end
641 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
642 end do
643
644 q_prim_vf(eqn_idx%mom%beg)%sf(m + j, k, l) = -q_prim_vf(eqn_idx%mom%beg)%sf(m - (j - 1), k, l)
645
646 do i = eqn_idx%mom%beg + 1, sys_size
647 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
648 end do
649
650 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
651 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m - (j - 1), k, l)
652 end if
653
654 if (hypoelasticity) then
655 do i = 1, shear_bc_flip_num
656 q_prim_vf(shear_bc_flip_indices(1, i))%sf(m + j, k, l) = -q_prim_vf(shear_bc_flip_indices(1, &
657 & i))%sf(m - (j - 1), k, l)
658 end do
659 end if
660 end do
661 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
662 do i = 1, nb
663 do q = 1, nnode
664 do j = 1, buff_size
665 pb_in(m + j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i)
666 mv_in(m + j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i)
667 end do
668 end do
669 end do
670 end if
671 end if
672 else if (bc_dir == 2) then !< y-direction
673 if (bc_loc == -1) then !< bc_y%beg
674 do j = 1, buff_size
675 do i = 1, eqn_idx%mom%beg
676 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l)
677 end do
678
679 q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, -j, l) = -q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, j - 1, l)
680
681 do i = eqn_idx%mom%beg + 2, sys_size
682 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l)
683 end do
684
685 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
686 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, j - 1, l)
687 end if
688
689 if (hypoelasticity) then
690 do i = 1, shear_bc_flip_num
691 q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, -j, l) = -q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, &
692 & j - 1, l)
693 end do
694 end if
695 end do
696
697 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
698 do i = 1, nb
699 do q = 1, nnode
700 do j = 1, buff_size
701 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l, q, i)
702 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l, q, i)
703 end do
704 end do
705 end do
706 end if
707 else !< bc_y%end
708 do j = 1, buff_size
709 do i = 1, eqn_idx%mom%beg
710 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
711 end do
712
713 q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, n + j, l) = -q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, n - (j - 1), l)
714
715 do i = eqn_idx%mom%beg + 2, sys_size
716 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
717 end do
718
719 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
720 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n - (j - 1), l)
721 end if
722
723 if (hypoelasticity) then
724 do i = 1, shear_bc_flip_num
725 q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, n + j, l) = -q_prim_vf(shear_bc_flip_indices(2, &
726 & i))%sf(k, n - (j - 1), l)
727 end do
728 end if
729 end do
730
731 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
732 do i = 1, nb
733 do q = 1, nnode
734 do j = 1, buff_size
735 pb_in(k, n + j, l, q, i) = pb_in(k, n - (j - 1), l, q, i)
736 mv_in(k, n + j, l, q, i) = mv_in(k, n - (j - 1), l, q, i)
737 end do
738 end do
739 end do
740 end if
741 end if
742 else if (bc_dir == 3) then !< z-direction
743 if (bc_loc == -1) then !< bc_z%beg
744 do j = 1, buff_size
745 do i = 1, eqn_idx%mom%beg + 1
746 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1)
747 end do
748
749 q_prim_vf(eqn_idx%mom%end)%sf(k, l, -j) = -q_prim_vf(eqn_idx%mom%end)%sf(k, l, j - 1)
750
751 do i = eqn_idx%E, sys_size
752 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1)
753 end do
754
755 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
756 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, j - 1)
757 end if
758
759 if (hypoelasticity) then
760 do i = 1, shear_bc_flip_num
761 q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, l, -j) = -q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, &
762 & l, j - 1)
763 end do
764 end if
765 end do
766
767 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
768 do i = 1, nb
769 do q = 1, nnode
770 do j = 1, buff_size
771 pb_in(k, l, -j, q, i) = pb_in(k, l, j - 1, q, i)
772 mv_in(k, l, -j, q, i) = mv_in(k, l, j - 1, q, i)
773 end do
774 end do
775 end do
776 end if
777 else !< bc_z%end
778 do j = 1, buff_size
779 do i = 1, eqn_idx%mom%beg + 1
780 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
781 end do
782
783 q_prim_vf(eqn_idx%mom%end)%sf(k, l, p + j) = -q_prim_vf(eqn_idx%mom%end)%sf(k, l, p - (j - 1))
784
785 do i = eqn_idx%E, sys_size
786 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
787 end do
788
789 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
790 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p - (j - 1))
791 end if
792
793 if (hypoelasticity) then
794 do i = 1, shear_bc_flip_num
795 q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, l, p + j) = -q_prim_vf(shear_bc_flip_indices(3, &
796 & i))%sf(k, l, p - (j - 1))
797 end do
798 end if
799 end do
800
801 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
802 do i = 1, nb
803 do q = 1, nnode
804 do j = 1, buff_size
805 pb_in(k, l, p + j, q, i) = pb_in(k, l, p - (j - 1), q, i)
806 mv_in(k, l, p + j, q, i) = mv_in(k, l, p - (j - 1), q, i)
807 end do
808 end do
809 end do
810 end if
811 end if
812 end if
813
814 end subroutine s_symmetry
815
816 !> Apply periodic boundary conditions by copying values from the opposite domain boundary.
817 subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
818
819
820# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
821#if MFC_OpenACC
822# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
823!$acc routine seq
824# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
825#elif MFC_OpenMP
826# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
827
828# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
829
830# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
831!$omp declare target device_type(any)
832# 363 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
833#endif
834# 364 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
835 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
836 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
837 integer, intent(in) :: bc_dir, bc_loc
838 integer, intent(in) :: k, l
839 integer :: j, q, i
840 type(scalar_field), optional, intent(inout) :: q_T_sf
841
842 if (bc_dir == 1) then !< x-direction
843 if (bc_loc == -1) then !< bc_x%beg
844 do i = 1, sys_size
845 do j = 1, buff_size
846 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
847 end do
848 end do
849
850 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
851 do j = 1, buff_size
852 q_t_sf%sf(-j, k, l) = q_t_sf%sf(m - (j - 1), k, l)
853 end do
854 end if
855
856 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
857 do i = 1, nb
858 do q = 1, nnode
859 do j = 1, buff_size
860 pb_in(-j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i)
861 mv_in(-j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i)
862 end do
863 end do
864 end do
865 end if
866 else !< bc_x%end
867 do i = 1, sys_size
868 do j = 1, buff_size
869 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
870 end do
871 end do
872
873 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
874 do j = 1, buff_size
875 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(j - 1, k, l)
876 end do
877 end if
878
879 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
880 do i = 1, nb
881 do q = 1, nnode
882 do j = 1, buff_size
883 pb_in(m + j, k, l, q, i) = pb_in(j - 1, k, l, q, i)
884 mv_in(m + j, k, l, q, i) = mv_in(j - 1, k, l, q, i)
885 end do
886 end do
887 end do
888 end if
889 end if
890 else if (bc_dir == 2) then !< y-direction
891 if (bc_loc == -1) then !< bc_y%beg
892 do i = 1, sys_size
893 do j = 1, buff_size
894 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
895 end do
896 end do
897
898 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
899 do j = 1, buff_size
900 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, n - (j - 1), l)
901 end do
902 end if
903
904 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
905 do i = 1, nb
906 do q = 1, nnode
907 do j = 1, buff_size
908 pb_in(k, -j, l, q, i) = pb_in(k, n - (j - 1), l, q, i)
909 mv_in(k, -j, l, q, i) = mv_in(k, n - (j - 1), l, q, i)
910 end do
911 end do
912 end do
913 end if
914 else !< bc_y%end
915 do i = 1, sys_size
916 do j = 1, buff_size
917 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, j - 1, l)
918 end do
919 end do
920
921 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
922 do j = 1, buff_size
923 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, j - 1, l)
924 end do
925 end if
926
927 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
928 do i = 1, nb
929 do q = 1, nnode
930 do j = 1, buff_size
931 pb_in(k, n + j, l, q, i) = pb_in(k, (j - 1), l, q, i)
932 mv_in(k, n + j, l, q, i) = mv_in(k, (j - 1), l, q, i)
933 end do
934 end do
935 end do
936 end if
937 end if
938 else if (bc_dir == 3) then !< z-direction
939 if (bc_loc == -1) then !< bc_z%beg
940 do i = 1, sys_size
941 do j = 1, buff_size
942 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
943 end do
944 end do
945
946 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
947 do j = 1, buff_size
948 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, p - (j - 1))
949 end do
950 end if
951
952 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
953 do i = 1, nb
954 do q = 1, nnode
955 do j = 1, buff_size
956 pb_in(k, l, -j, q, i) = pb_in(k, l, p - (j - 1), q, i)
957 mv_in(k, l, -j, q, i) = mv_in(k, l, p - (j - 1), q, i)
958 end do
959 end do
960 end do
961 end if
962 else !< bc_z%end
963 do i = 1, sys_size
964 do j = 1, buff_size
965 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, j - 1)
966 end do
967 end do
968
969 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
970 do j = 1, buff_size
971 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, j - 1)
972 end do
973 end if
974
975 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
976 do i = 1, nb
977 do q = 1, nnode
978 do j = 1, buff_size
979 pb_in(k, l, p + j, q, i) = pb_in(k, l, j - 1, q, i)
980 mv_in(k, l, p + j, q, i) = mv_in(k, l, j - 1, q, i)
981 end do
982 end do
983 end do
984 end if
985 end if
986 end if
987
988 end subroutine s_periodic
989
990 !> Apply axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase shift.
991 subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l, q_T_sf)
992
993
994# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
995#if MFC_OpenACC
996# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
997!$acc routine seq
998# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
999#elif MFC_OpenMP
1000# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1001
1002# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1003
1004# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1005!$omp declare target device_type(any)
1006# 522 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1007#endif
1008# 523 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1009 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1010 real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), optional, intent(inout) :: pb_in, mv_in
1011 integer, intent(in) :: k, l
1012 integer :: j, q, i, l_opp
1013 type(scalar_field), optional, intent(inout) :: q_T_sf
1014
1015 do j = 1, buff_size
1016 if (z_cc(l) < pi) then
1017 do i = 1, eqn_idx%mom%beg
1018 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2))
1019 end do
1020
1021 q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, -j, l) = -q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, j - 1, l + ((p + 1)/2))
1022
1023 q_prim_vf(eqn_idx%mom%end)%sf(k, -j, l) = -q_prim_vf(eqn_idx%mom%end)%sf(k, j - 1, l + ((p + 1)/2))
1024
1025 do i = eqn_idx%E, sys_size
1026 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2))
1027 end do
1028 else
1029 do i = 1, eqn_idx%mom%beg
1030 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2))
1031 end do
1032
1033 q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, -j, l) = -q_prim_vf(eqn_idx%mom%beg + 1)%sf(k, j - 1, l - ((p + 1)/2))
1034
1035 q_prim_vf(eqn_idx%mom%end)%sf(k, -j, l) = -q_prim_vf(eqn_idx%mom%end)%sf(k, j - 1, l - ((p + 1)/2))
1036
1037 do i = eqn_idx%E, sys_size
1038 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2))
1039 end do
1040 end if
1041 end do
1042
1043 ! Temperature is a scalar, so it crosses the axis like the scalars above: same half-turn partner, no sign flip.
1044 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1045 l_opp = l + ((p + 1)/2)
1046 if (z_cc(l) >= pi) l_opp = l - ((p + 1)/2)
1047 do j = 1, buff_size
1048 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, j - 1, l_opp)
1049 end do
1050 end if
1051
1052 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
1053 do i = 1, nb
1054 do q = 1, nnode
1055 do j = 1, buff_size
1056 if (z_cc(l) < pi) then
1057 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l + ((p + 1)/2), q, i)
1058 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l + ((p + 1)/2), q, i)
1059 else
1060 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l - ((p + 1)/2), q, i)
1061 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l - ((p + 1)/2), q, i)
1062 end if
1063 end do
1064 end do
1065 end do
1066 end if
1067
1068 end subroutine s_axis
1069
1070 !> Apply slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component.
1071 subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
1072
1073
1074# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1075#ifdef _CRAYFTN
1076# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1077#if MFC_OpenACC
1078# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1079!$acc routine seq
1080# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1081#elif MFC_OpenMP
1082# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1083
1084# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1085
1086# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1087!$omp declare target device_type(any)
1088# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1089#else
1090# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1091!DIR$ INLINEALWAYS s_slip_wall
1092# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1093#endif
1094# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1095#elif MFC_OpenACC
1096# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1097!$acc routine seq
1098# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1099#elif MFC_OpenMP
1100# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1101
1102# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1103
1104# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1105!$omp declare target device_type(any)
1106# 587 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1107#endif
1108# 588 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1109 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1110 integer, intent(in) :: bc_dir, bc_loc
1111 integer, intent(in) :: k, l
1112 integer :: j, i
1113 type(scalar_field), optional, intent(inout) :: q_T_sf
1114
1115 if (bc_dir == 1) then !< x-direction
1116 if (bc_loc == -1) then !< bc_x%beg
1117 do i = 1, sys_size
1118 do j = 1, buff_size
1119 if (i == eqn_idx%mom%beg) then
1120 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1
1121 else
1122 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
1123 end if
1124 end do
1125 end do
1126
1127 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1128 if (bc_x%isothermal_in) then
1129 do j = 1, buff_size
1130 q_t_sf%sf(-j, k, l) = 2._wp*bc_x%Twall_in - q_t_sf%sf(j - 1, k, l)
1131 end do
1132 else
1133 do j = 1, buff_size
1134 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
1135 end do
1136 end if
1137 end if
1138 else !< bc_x%end
1139 do i = 1, sys_size
1140 do j = 1, buff_size
1141 if (i == eqn_idx%mom%beg) then
1142 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1
1143 else
1144 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
1145 end if
1146 end do
1147 end do
1148
1149 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1150 if (bc_x%isothermal_out) then
1151 do j = 1, buff_size
1152 q_t_sf%sf(m + j, k, l) = 2._wp*bc_x%Twall_out - q_t_sf%sf(m - (j - 1), k, l)
1153 end do
1154 else
1155 do j = 1, buff_size
1156 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
1157 end do
1158 end if
1159 end if
1160 end if
1161 else if (bc_dir == 2) then !< y-direction
1162 if (bc_loc == -1) then !< bc_y%beg
1163 do i = 1, sys_size
1164 do j = 1, buff_size
1165 if (i == eqn_idx%mom%beg + 1) then
1166 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2
1167 else
1168 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
1169 end if
1170 end do
1171 end do
1172
1173 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1174 if (bc_y%isothermal_in) then
1175 do j = 1, buff_size
1176 q_t_sf%sf(k, -j, l) = 2._wp*bc_y%Twall_in - q_t_sf%sf(k, j - 1, l)
1177 end do
1178 else
1179 do j = 1, buff_size
1180 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
1181 end do
1182 end if
1183 end if
1184 else !< bc_y%end
1185 do i = 1, sys_size
1186 do j = 1, buff_size
1187 if (i == eqn_idx%mom%beg + 1) then
1188 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2
1189 else
1190 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
1191 end if
1192 end do
1193 end do
1194
1195 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1196 if (bc_y%isothermal_out) then
1197 do j = 1, buff_size
1198 q_t_sf%sf(k, n + j, l) = 2._wp*bc_y%Twall_out - q_t_sf%sf(k, n - (j - 1), l)
1199 end do
1200 else
1201 do j = 1, buff_size
1202 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
1203 end do
1204 end if
1205 end if
1206 end if
1207 else if (bc_dir == 3) then !< z-direction
1208 if (bc_loc == -1) then !< bc_z%beg
1209 do i = 1, sys_size
1210 do j = 1, buff_size
1211 if (i == eqn_idx%mom%end) then
1212 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3
1213 else
1214 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
1215 end if
1216 end do
1217 end do
1218
1219 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1220 if (bc_z%isothermal_in) then
1221 do j = 1, buff_size
1222 q_t_sf%sf(k, l, -j) = 2._wp*bc_z%Twall_in - q_t_sf%sf(k, l, j - 1)
1223 end do
1224 else
1225 do j = 1, buff_size
1226 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, 0)
1227 end do
1228 end if
1229 end if
1230 else !< bc_z%end
1231 do i = 1, sys_size
1232 do j = 1, buff_size
1233 if (i == eqn_idx%mom%end) then
1234 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3
1235 else
1236 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
1237 end if
1238 end do
1239 end do
1240
1241 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1242 if (bc_z%isothermal_out) then
1243 do j = 1, buff_size
1244 q_t_sf%sf(k, l, p + j) = 2._wp*bc_z%Twall_out - q_t_sf%sf(k, l, p - (j - 1))
1245 end do
1246 else
1247 do j = 1, buff_size
1248 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
1249 end do
1250 end if
1251 end if
1252 end if
1253 end if
1254
1255 end subroutine s_slip_wall
1256
1257 !> Apply no-slip wall boundary conditions by reflecting and negating all velocity components at the wall.
1258 subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
1259
1260
1261# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1262#ifdef _CRAYFTN
1263# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1264#if MFC_OpenACC
1265# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1266!$acc routine seq
1267# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1268#elif MFC_OpenMP
1269# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1270
1271# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1272
1273# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1274!$omp declare target device_type(any)
1275# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1276#else
1277# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1278!DIR$ INLINEALWAYS s_no_slip_wall
1279# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1280#endif
1281# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1282#elif MFC_OpenACC
1283# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1284!$acc routine seq
1285# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1286#elif MFC_OpenMP
1287# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1288
1289# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1290
1291# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1292!$omp declare target device_type(any)
1293# 739 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1294#endif
1295# 740 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1296
1297 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1298 integer, intent(in) :: bc_dir, bc_loc
1299 integer, intent(in) :: k, l
1300 integer :: j, i
1301 type(scalar_field), optional, intent(inout) :: q_T_sf
1302
1303 if (bc_dir == 1) then !< x-direction
1304 if (bc_loc == -1) then !< bc_x%beg
1305 do i = 1, sys_size
1306 do j = 1, buff_size
1307 if (i == eqn_idx%mom%beg) then
1308 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1
1309 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1310 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb2
1311 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1312 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb3
1313 else
1314 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
1315 end if
1316 end do
1317 end do
1318
1319 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1320 if (bc_x%isothermal_in) then
1321 do j = 1, buff_size
1322 q_t_sf%sf(-j, k, l) = 2._wp*bc_x%Twall_in - q_t_sf%sf(j - 1, k, l)
1323 end do
1324 else
1325 do j = 1, buff_size
1326 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
1327 end do
1328 end if
1329 end if
1330 else !< bc_x%end
1331 do i = 1, sys_size
1332 do j = 1, buff_size
1333 if (i == eqn_idx%mom%beg) then
1334 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1
1335 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1336 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve2
1337 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1338 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve3
1339 else
1340 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
1341 end if
1342 end do
1343 end do
1344
1345 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1346 if (bc_x%isothermal_out) then
1347 do j = 1, buff_size
1348 q_t_sf%sf(m + j, k, l) = 2._wp*bc_x%Twall_out - q_t_sf%sf(m - (j - 1), k, l)
1349 end do
1350 else
1351 do j = 1, buff_size
1352 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
1353 end do
1354 end if
1355 end if
1356 end if
1357 else if (bc_dir == 2) then !< y-direction
1358 if (bc_loc == -1) then !< bc_y%beg
1359 do i = 1, sys_size
1360 do j = 1, buff_size
1361 if (i == eqn_idx%mom%beg) then
1362 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb1
1363 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1364 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2
1365 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1366 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb3
1367 else
1368 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
1369 end if
1370 end do
1371 end do
1372 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1373 if (bc_y%isothermal_in) then
1374 do j = 1, buff_size
1375 q_t_sf%sf(k, -j, l) = 2._wp*bc_y%Twall_in - q_t_sf%sf(k, j - 1, l)
1376 end do
1377 else
1378 do j = 1, buff_size
1379 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
1380 end do
1381 end if
1382 end if
1383 else !< bc_y%end
1384 do i = 1, sys_size
1385 do j = 1, buff_size
1386 if (i == eqn_idx%mom%beg) then
1387 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve1
1388 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1389 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2
1390 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1391 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve3
1392 else
1393 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
1394 end if
1395 end do
1396 end do
1397 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1398 if (bc_y%isothermal_out) then
1399 do j = 1, buff_size
1400 q_t_sf%sf(k, n + j, l) = 2._wp*bc_y%Twall_out - q_t_sf%sf(k, n - (j - 1), l)
1401 end do
1402 else
1403 do j = 1, buff_size
1404 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
1405 end do
1406 end if
1407 end if
1408 end if
1409 else if (bc_dir == 3) then !< z-direction
1410 if (bc_loc == -1) then !< bc_z%beg
1411 do i = 1, sys_size
1412 do j = 1, buff_size
1413 if (i == eqn_idx%mom%beg) then
1414 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb1
1415 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1416 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb2
1417 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1418 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3
1419 else
1420 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
1421 end if
1422 end do
1423 end do
1424 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1425 if (bc_z%isothermal_in) then
1426 do j = 1, buff_size
1427 q_t_sf%sf(k, l, -j) = 2._wp*bc_z%Twall_in - q_t_sf%sf(k, l, j - 1)
1428 end do
1429 else
1430 do j = 1, buff_size
1431 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, 0)
1432 end do
1433 end if
1434 end if
1435 else !< bc_z%end
1436 do i = 1, sys_size
1437 do j = 1, buff_size
1438 if (i == eqn_idx%mom%beg) then
1439 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve1
1440 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1441 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve2
1442 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1443 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3
1444 else
1445 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
1446 end if
1447 end do
1448 end do
1449 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1450 if (bc_z%isothermal_out) then
1451 do j = 1, buff_size
1452 q_t_sf%sf(k, l, p + j) = 2._wp*bc_z%Twall_out - q_t_sf%sf(k, l, p - (j - 1))
1453 end do
1454 else
1455 do j = 1, buff_size
1456 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
1457 end do
1458 end if
1459 end if
1460 end if
1461 end if
1462
1463 end subroutine s_no_slip_wall
1464
1465 !> Apply Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers.
1466 subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
1467
1468
1469# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1470#ifdef _CRAYFTN
1471# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1472#if MFC_OpenACC
1473# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1474!$acc routine seq
1475# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1476#elif MFC_OpenMP
1477# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1478
1479# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1480
1481# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1482!$omp declare target device_type(any)
1483# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1484#else
1485# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1486!DIR$ INLINEALWAYS s_dirichlet
1487# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1488#endif
1489# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1490#elif MFC_OpenACC
1491# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1492!$acc routine seq
1493# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1494#elif MFC_OpenMP
1495# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1496
1497# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1498
1499# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1500!$omp declare target device_type(any)
1501# 912 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1502#endif
1503# 913 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1504 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1505 integer, intent(in) :: bc_dir, bc_loc
1506 integer, intent(in) :: k, l
1507 integer :: j, i
1508 type(scalar_field), optional, intent(inout) :: q_T_sf
1509
1510 if (.not. dirichlet_from_buffers) then
1511 call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
1512 return
1513 end if
1514
1515 if (bc_dir == 1) then !< x-direction
1516 if (bc_loc == -1) then ! bc_x%beg
1517 do i = 1, sys_size
1518 do j = 1, buff_size
1519 q_prim_vf(i)%sf(-j, k, l) = bc_buffers(1, 1)%sf(i, k, l)*f_dir_vel(i, 1)
1520 end do
1521 end do
1522 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1523 do j = 1, buff_size
1524 q_t_sf%sf(-j, k, l) = bc_buffers(1, 1)%sf(sys_size + 1, k, l)
1525 end do
1526 end if
1527 else !< bc_x%end
1528 do i = 1, sys_size
1529 do j = 1, buff_size
1530 q_prim_vf(i)%sf(m + j, k, l) = bc_buffers(1, 2)%sf(i, k, l)*f_dir_vel(i, 1)
1531 end do
1532 end do
1533 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1534 do j = 1, buff_size
1535 q_t_sf%sf(m + j, k, l) = bc_buffers(1, 2)%sf(sys_size + 1, k, l)
1536 end do
1537 end if
1538 end if
1539 else if (bc_dir == 2) then !< y-direction
1540# 950 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1541 if (bc_loc == -1) then !< bc_y%beg
1542 do i = 1, sys_size
1543 do j = 1, buff_size
1544 q_prim_vf(i)%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, i, l)*f_dir_vel(i, 2)
1545 end do
1546 end do
1547 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1548 do j = 1, buff_size
1549 q_t_sf%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, sys_size + 1, l)
1550 end do
1551 end if
1552 else !< bc_y%end
1553 do i = 1, sys_size
1554 do j = 1, buff_size
1555 q_prim_vf(i)%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, i, l)*f_dir_vel(i, 2)
1556 end do
1557 end do
1558 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1559 do j = 1, buff_size
1560 q_t_sf%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, sys_size + 1, l)
1561 end do
1562 end if
1563 end if
1564# 974 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1565 else if (bc_dir == 3) then !< z-direction
1566# 976 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1567 if (bc_loc == -1) then !< bc_z%beg
1568 do i = 1, sys_size
1569 do j = 1, buff_size
1570 q_prim_vf(i)%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, i)*f_dir_vel(i, 3)
1571 end do
1572 end do
1573 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1574 do j = 1, buff_size
1575 q_t_sf%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, sys_size + 1)
1576 end do
1577 end if
1578 else !< bc_z%end
1579 do i = 1, sys_size
1580 do j = 1, buff_size
1581 q_prim_vf(i)%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, i)*f_dir_vel(i, 3)
1582 end do
1583 end do
1584 if ((chemistry .or. heat_conduction) .and. present(q_t_sf)) then
1585 do j = 1, buff_size
1586 q_t_sf%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, sys_size + 1)
1587 end do
1588 end if
1589 end if
1590# 1000 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1591 end if
1592
1593 end subroutine s_dirichlet
1594
1595 !> Ramp factor for variable i of a Dirichlet ghost cell on a dir-normal face: bc_vel_ramp(dir) for velocities, else 1
1596 pure function f_dir_vel(i, dir) result(f)
1597
1598
1599# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1600#if MFC_OpenACC
1601# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1602!$acc routine seq
1603# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1604#elif MFC_OpenMP
1605# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1606
1607# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1608
1609# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1610!$omp declare target device_type(any)
1611# 1007 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1612#endif
1613# 1008 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1614 integer, intent(in) :: i, dir
1615 real(wp) :: f
1616
1617 f = merge(bc_vel_ramp(dir), 1._wp, i >= eqn_idx%mom%beg .and. i <= eqn_idx%mom%end)
1618
1619 end function f_dir_vel
1620
1621 !> Extrapolate QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values.
1622 subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in)
1623
1624
1625# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1626#if MFC_OpenACC
1627# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1628!$acc routine seq
1629# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1630#elif MFC_OpenMP
1631# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1632
1633# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1634
1635# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1636!$omp declare target device_type(any)
1637# 1018 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1638#endif
1639# 1019 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1640 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
1641 integer, intent(in) :: bc_dir, bc_loc
1642 integer, intent(in) :: k, l
1643 integer :: j, q, i
1644
1645 if (bc_dir == 1) then !< x-direction
1646 if (bc_loc == -1) then ! bc_x%beg
1647 do i = 1, nb
1648 do q = 1, nnode
1649 do j = 1, buff_size
1650 pb_in(-j, k, l, q, i) = pb_in(0, k, l, q, i)
1651 mv_in(-j, k, l, q, i) = mv_in(0, k, l, q, i)
1652 end do
1653 end do
1654 end do
1655 else !< bc_x%end
1656 do i = 1, nb
1657 do q = 1, nnode
1658 do j = 1, buff_size
1659 pb_in(m + j, k, l, q, i) = pb_in(m, k, l, q, i)
1660 mv_in(m + j, k, l, q, i) = mv_in(m, k, l, q, i)
1661 end do
1662 end do
1663 end do
1664 end if
1665 else if (bc_dir == 2) then !< y-direction
1666 if (bc_loc == -1) then !< bc_y%beg
1667 do i = 1, nb
1668 do q = 1, nnode
1669 do j = 1, buff_size
1670 pb_in(k, -j, l, q, i) = pb_in(k, 0, l, q, i)
1671 mv_in(k, -j, l, q, i) = mv_in(k, 0, l, q, i)
1672 end do
1673 end do
1674 end do
1675 else !< bc_y%end
1676 do i = 1, nb
1677 do q = 1, nnode
1678 do j = 1, buff_size
1679 pb_in(k, n + j, l, q, i) = pb_in(k, n, l, q, i)
1680 mv_in(k, n + j, l, q, i) = mv_in(k, n, l, q, i)
1681 end do
1682 end do
1683 end do
1684 end if
1685 else if (bc_dir == 3) then !< z-direction
1686 if (bc_loc == -1) then !< bc_z%beg
1687 do i = 1, nb
1688 do q = 1, nnode
1689 do j = 1, buff_size
1690 pb_in(k, l, -j, q, i) = pb_in(k, l, 0, q, i)
1691 mv_in(k, l, -j, q, i) = mv_in(k, l, 0, q, i)
1692 end do
1693 end do
1694 end do
1695 else !< bc_z%end
1696 do i = 1, nb
1697 do q = 1, nnode
1698 do j = 1, buff_size
1699 pb_in(k, l, p + j, q, i) = pb_in(k, l, p, q, i)
1700 mv_in(k, l, p + j, q, i) = mv_in(k, l, p, q, i)
1701 end do
1702 end do
1703 end do
1704 end if
1705 end if
1706
1707 end subroutine s_qbmm_extrapolation
1708
1709 !> Apply periodic boundary conditions to the color function and its divergence fields.
1710 subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l)
1711
1712
1713# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1714#ifdef _CRAYFTN
1715# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1716#if MFC_OpenACC
1717# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1718!$acc routine seq
1719# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1720#elif MFC_OpenMP
1721# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1722
1723# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1724
1725# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1726!$omp declare target device_type(any)
1727# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1728#else
1729# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1730!DIR$ INLINEALWAYS s_color_function_periodic
1731# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1732#endif
1733# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1734#elif MFC_OpenACC
1735# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1736!$acc routine seq
1737# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1738#elif MFC_OpenMP
1739# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1740
1741# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1742
1743# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1744!$omp declare target device_type(any)
1745# 1091 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1746#endif
1747# 1092 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1748 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1749 integer, intent(in) :: bc_dir, bc_loc
1750 integer, intent(in) :: k, l
1751 integer :: j, i
1752
1753 if (bc_dir == 1) then !< x-direction
1754 if (bc_loc == -1) then ! bc_x%beg
1755 do i = 1, num_dims + 1
1756 do j = 1, buff_size
1757 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(m - (j - 1), k, l)
1758 end do
1759 end do
1760 else !< bc_x%end
1761 do i = 1, num_dims + 1
1762 do j = 1, buff_size
1763 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(j - 1, k, l)
1764 end do
1765 end do
1766 end if
1767 else if (bc_dir == 2) then !< y-direction
1768 if (bc_loc == -1) then !< bc_y%beg
1769 do i = 1, num_dims + 1
1770 do j = 1, buff_size
1771 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, n - (j - 1), l)
1772 end do
1773 end do
1774 else !< bc_y%end
1775 do i = 1, num_dims + 1
1776 do j = 1, buff_size
1777 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, j - 1, l)
1778 end do
1779 end do
1780 end if
1781 else if (bc_dir == 3) then !< z-direction
1782 if (bc_loc == -1) then !< bc_z%beg
1783 do i = 1, num_dims + 1
1784 do j = 1, buff_size
1785 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, p - (j - 1))
1786 end do
1787 end do
1788 else !< bc_z%end
1789 do i = 1, num_dims + 1
1790 do j = 1, buff_size
1791 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, j - 1)
1792 end do
1793 end do
1794 end if
1795 end if
1796
1797 end subroutine s_color_function_periodic
1798
1799 !> Apply reflective boundary conditions to the color function and its divergence fields.
1800 subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l)
1801
1802
1803# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1804#ifdef _CRAYFTN
1805# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1806#if MFC_OpenACC
1807# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1808!$acc routine seq
1809# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1810#elif MFC_OpenMP
1811# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1812
1813# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1814
1815# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1816!$omp declare target device_type(any)
1817# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1818#else
1819# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1820!DIR$ INLINEALWAYS s_color_function_reflective
1821# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1822#endif
1823# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1824#elif MFC_OpenACC
1825# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1826!$acc routine seq
1827# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1828#elif MFC_OpenMP
1829# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1830
1831# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1832
1833# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1834!$omp declare target device_type(any)
1835# 1146 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1836#endif
1837# 1147 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1838 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1839 integer, intent(in) :: bc_dir, bc_loc
1840 integer, intent(in) :: k, l
1841 integer :: j, i
1842
1843 if (bc_dir == 1) then !< x-direction
1844 if (bc_loc == -1) then ! bc_x%beg
1845 do i = 1, num_dims + 1
1846 do j = 1, buff_size
1847 if (i == bc_dir) then
1848 c_divs(i)%sf(-j, k, l) = -c_divs(i)%sf(j - 1, k, l)
1849 else
1850 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(j - 1, k, l)
1851 end if
1852 end do
1853 end do
1854 else !< bc_x%end
1855 do i = 1, num_dims + 1
1856 do j = 1, buff_size
1857 if (i == bc_dir) then
1858 c_divs(i)%sf(m + j, k, l) = -c_divs(i)%sf(m - (j - 1), k, l)
1859 else
1860 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(m - (j - 1), k, l)
1861 end if
1862 end do
1863 end do
1864 end if
1865 else if (bc_dir == 2) then !< y-direction
1866 if (bc_loc == -1) then !< bc_y%beg
1867 do i = 1, num_dims + 1
1868 do j = 1, buff_size
1869 if (i == bc_dir) then
1870 c_divs(i)%sf(k, -j, l) = -c_divs(i)%sf(k, j - 1, l)
1871 else
1872 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, j - 1, l)
1873 end if
1874 end do
1875 end do
1876 else !< bc_y%end
1877 do i = 1, num_dims + 1
1878 do j = 1, buff_size
1879 if (i == bc_dir) then
1880 c_divs(i)%sf(k, n + j, l) = -c_divs(i)%sf(k, n - (j - 1), l)
1881 else
1882 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, n - (j - 1), l)
1883 end if
1884 end do
1885 end do
1886 end if
1887 else if (bc_dir == 3) then !< z-direction
1888 if (bc_loc == -1) then !< bc_z%beg
1889 do i = 1, num_dims + 1
1890 do j = 1, buff_size
1891 if (i == bc_dir) then
1892 c_divs(i)%sf(k, l, -j) = -c_divs(i)%sf(k, l, j - 1)
1893 else
1894 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, j - 1)
1895 end if
1896 end do
1897 end do
1898 else !< bc_z%end
1899 do i = 1, num_dims + 1
1900 do j = 1, buff_size
1901 if (i == bc_dir) then
1902 c_divs(i)%sf(k, l, p + j) = -c_divs(i)%sf(k, l, p - (j - 1))
1903 else
1904 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, p - (j - 1))
1905 end if
1906 end do
1907 end do
1908 end if
1909 end if
1910
1911 end subroutine s_color_function_reflective
1912
1913 !> Extrapolate the color function and its divergence into ghost cells by copying boundary values.
1914 subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l)
1915
1916
1917# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1918#ifdef _CRAYFTN
1919# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1920#if MFC_OpenACC
1921# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1922!$acc routine seq
1923# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1924#elif MFC_OpenMP
1925# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1926
1927# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1928
1929# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1930!$omp declare target device_type(any)
1931# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1932#else
1933# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1934!DIR$ INLINEALWAYS s_color_function_ghost_cell_extrapolation
1935# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1936#endif
1937# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1938#elif MFC_OpenACC
1939# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1940!$acc routine seq
1941# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1942#elif MFC_OpenMP
1943# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1944
1945# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1946
1947# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1948!$omp declare target device_type(any)
1949# 1225 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1950#endif
1951# 1226 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1952 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1953 integer, intent(in) :: bc_dir, bc_loc
1954 integer, intent(in) :: k, l
1955 integer :: j, i
1956
1957 if (bc_dir == 1) then !< x-direction
1958 if (bc_loc == -1) then ! bc_x%beg
1959 do i = 1, num_dims + 1
1960 do j = 1, buff_size
1961 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(0, k, l)
1962 end do
1963 end do
1964 else !< bc_x%end
1965 do i = 1, num_dims + 1
1966 do j = 1, buff_size
1967 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(m, k, l)
1968 end do
1969 end do
1970 end if
1971 else if (bc_dir == 2) then !< y-direction
1972 if (bc_loc == -1) then !< bc_y%beg
1973 do i = 1, num_dims + 1
1974 do j = 1, buff_size
1975 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, 0, l)
1976 end do
1977 end do
1978 else !< bc_y%end
1979 do i = 1, num_dims + 1
1980 do j = 1, buff_size
1981 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, n, l)
1982 end do
1983 end do
1984 end if
1985 else if (bc_dir == 3) then !< z-direction
1986 if (bc_loc == -1) then !< bc_z%beg
1987 do i = 1, num_dims + 1
1988 do j = 1, buff_size
1989 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, 0)
1990 end do
1991 end do
1992 else !< bc_z%end
1993 do i = 1, num_dims + 1
1994 do j = 1, buff_size
1995 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, p)
1996 end do
1997 end do
1998 end if
1999 end if
2000
2001 end subroutine s_color_function_ghost_cell_extrapolation
2002
2003 !> Apply periodic boundary conditions to the IGR Jacobian field by copying values from the opposite domain boundary.
2004 subroutine s_f_igr_periodic(jac_sf, bc_dir, bc_loc, k, l)
2005
2006
2007# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2008#ifdef _CRAYFTN
2009# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2010#if MFC_OpenACC
2011# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2012!$acc routine seq
2013# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2014#elif MFC_OpenMP
2015# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2016
2017# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2018
2019# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2020!$omp declare target device_type(any)
2021# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2022#else
2023# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2024!DIR$ INLINEALWAYS s_F_igr_periodic
2025# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2026#endif
2027# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2028#elif MFC_OpenACC
2029# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2030!$acc routine seq
2031# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2032#elif MFC_OpenMP
2033# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2034
2035# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2036
2037# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2038!$omp declare target device_type(any)
2039# 1280 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2040#endif
2041# 1281 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2042 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
2043 integer, intent(in) :: bc_dir, bc_loc
2044 integer, intent(in) :: k, l
2045 integer :: j
2046
2047 if (bc_dir == 1) then
2048 if (bc_loc == -1) then
2049 do j = 1, buff_size
2050 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(m - j + 1, k, l)
2051 end do
2052 else
2053 do j = 1, buff_size
2054 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(j - 1, k, l)
2055 end do
2056 end if
2057 else if (bc_dir == 2) then
2058 if (bc_loc == -1) then
2059 do j = 1, buff_size
2060 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, n - j + 1, l)
2061 end do
2062 else
2063 do j = 1, buff_size
2064 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, j - 1, l)
2065 end do
2066 end if
2067 else
2068 if (bc_loc == -1) then
2069 do j = 1, buff_size
2070 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, p - j + 1)
2071 end do
2072 else
2073 do j = 1, buff_size
2074 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, j - 1)
2075 end do
2076 end if
2077 end if
2078
2079 end subroutine s_f_igr_periodic
2080
2081 !> Apply reflective boundary conditions to the IGR Jacobian field by mirroring values across the boundary.
2082 subroutine s_f_igr_reflective(jac_sf, bc_dir, bc_loc, k, l)
2083
2084
2085# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2086#ifdef _CRAYFTN
2087# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2088#if MFC_OpenACC
2089# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2090!$acc routine seq
2091# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2092#elif MFC_OpenMP
2093# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2094
2095# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2096
2097# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2098!$omp declare target device_type(any)
2099# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2100#else
2101# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2102!DIR$ INLINEALWAYS s_F_igr_reflective
2103# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2104#endif
2105# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2106#elif MFC_OpenACC
2107# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2108!$acc routine seq
2109# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2110#elif MFC_OpenMP
2111# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2112
2113# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2114
2115# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2116!$omp declare target device_type(any)
2117# 1323 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2118#endif
2119# 1324 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2120 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
2121 integer, intent(in) :: bc_dir, bc_loc
2122 integer, intent(in) :: k, l
2123 integer :: j
2124
2125 if (bc_dir == 1) then
2126 if (bc_loc == -1) then
2127 do j = 1, buff_size
2128 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(j - 1, k, l)
2129 end do
2130 else
2131 do j = 1, buff_size
2132 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(m - (j - 1), k, l)
2133 end do
2134 end if
2135 else if (bc_dir == 2) then
2136 if (bc_loc == -1) then
2137 do j = 1, buff_size
2138 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, j - 1, l)
2139 end do
2140 else
2141 do j = 1, buff_size
2142 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, n - (j - 1), l)
2143 end do
2144 end if
2145 else
2146 if (bc_loc == -1) then
2147 do j = 1, buff_size
2148 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, j - 1)
2149 end do
2150 else
2151 do j = 1, buff_size
2152 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, p - (j - 1))
2153 end do
2154 end if
2155 end if
2156
2157 end subroutine s_f_igr_reflective
2158
2159 !> Extrapolate the IGR Jacobian field into ghost cells by copying boundary values.
2160 subroutine s_f_igr_ghost_cell_extrapolation(jac_sf, bc_dir, bc_loc, k, l)
2161
2162
2163# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2164#ifdef _CRAYFTN
2165# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2166#if MFC_OpenACC
2167# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2168!$acc routine seq
2169# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2170#elif MFC_OpenMP
2171# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2172
2173# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2174
2175# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2176!$omp declare target device_type(any)
2177# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2178#else
2179# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2180!DIR$ INLINEALWAYS s_F_igr_ghost_cell_extrapolation
2181# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2182#endif
2183# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2184#elif MFC_OpenACC
2185# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2186!$acc routine seq
2187# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2188#elif MFC_OpenMP
2189# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2190
2191# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2192
2193# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2194!$omp declare target device_type(any)
2195# 1366 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2196#endif
2197# 1367 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2198 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
2199 integer, intent(in) :: bc_dir, bc_loc
2200 integer, intent(in) :: k, l
2201 integer :: j
2202
2203 if (bc_dir == 1) then
2204 if (bc_loc == -1) then
2205 do j = 1, buff_size
2206 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(0, k, l)
2207 end do
2208 else
2209 do j = 1, buff_size
2210 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(m, k, l)
2211 end do
2212 end if
2213 else if (bc_dir == 2) then
2214 if (bc_loc == -1) then
2215 do j = 1, buff_size
2216 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, 0, l)
2217 end do
2218 else
2219 do j = 1, buff_size
2220 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, n, l)
2221 end do
2222 end if
2223 else
2224 if (bc_loc == -1) then
2225 do j = 1, buff_size
2226 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, 0)
2227 end do
2228 else
2229 do j = 1, buff_size
2230 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, p)
2231 end do
2232 end if
2233 end if
2234
2235 end subroutine s_f_igr_ghost_cell_extrapolation
2236
2237 subroutine s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
2238
2239
2240# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2241#ifdef _CRAYFTN
2242# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2243#if MFC_OpenACC
2244# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2245!$acc routine seq
2246# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2247#elif MFC_OpenMP
2248# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2249
2250# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2251
2252# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2253!$omp declare target device_type(any)
2254# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2255#else
2256# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2257!DIR$ INLINEALWAYS s_beta_periodic
2258# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2259#endif
2260# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2261#elif MFC_OpenACC
2262# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2263!$acc routine seq
2264# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2265#elif MFC_OpenMP
2266# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2267
2268# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2269
2270# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2271!$omp declare target device_type(any)
2272# 1408 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2273#endif
2274# 1409 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2275 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2276 type(scalar_field), dimension(num_dims + 1), intent(inout) :: kahan_comp
2277 integer, intent(in) :: bc_dir, bc_loc
2278 integer, intent(in) :: k, l
2279 integer, intent(in) :: nvar
2280 integer :: j, i
2281 real(wp) :: y_kahan, t_kahan
2282
2283 if (bc_dir == 1) then !< x-direction
2284 if (bc_loc == -1) then ! bc%x%beg
2285 do i = 1, nvar
2286 do j = -mapcells - 1, mapcells
2287 ! Kahan-compensated addition of ghost to interior
2288 y_kahan = real(q_beta(beta_vars(i))%sf(m + j + 1, k, l), &
2289 & kind=wp) + kahan_comp(beta_vars(i))%sf(m + j + 1, k, l) - kahan_comp(beta_vars(i))%sf(j, &
2290 & k, l)
2291 t_kahan = real(q_beta(beta_vars(i))%sf(j, k, l), kind=wp) + y_kahan
2292 kahan_comp(beta_vars(i))%sf(j, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j, k, l)) - y_kahan
2293 q_beta(beta_vars(i))%sf(j, k, l) = t_kahan
2294 end do
2295 end do
2296 else
2297 do i = 1, nvar
2298 do j = -mapcells, mapcells + 1
2299 q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l)
2300 kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2301 end do
2302 end do
2303 end if
2304 else if (bc_dir == 2) then !< y-direction
2305 if (bc_loc == -1) then !< bc%y%beg
2306 do i = 1, nvar
2307 do j = -mapcells - 1, mapcells
2308 y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j + 1, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, &
2309 & n + j + 1, l) - kahan_comp(beta_vars(i))%sf(k, j, l)
2310 t_kahan = real(q_beta(beta_vars(i))%sf(k, j, l), kind=wp) + y_kahan
2311 kahan_comp(beta_vars(i))%sf(k, j, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j, l)) - y_kahan
2312 q_beta(beta_vars(i))%sf(k, j, l) = t_kahan
2313 end do
2314 end do
2315 else
2316 do i = 1, nvar
2317 do j = -mapcells, mapcells + 1
2318 q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l)
2319 kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2320 end do
2321 end do
2322 end if
2323 else if (bc_dir == 3) then !< z-direction
2324 if (bc_loc == -1) then !< bc%z%beg
2325 do i = 1, nvar
2326 do j = -mapcells - 1, mapcells
2327 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j + 1), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2328 & p + j + 1) - kahan_comp(beta_vars(i))%sf(k, l, j)
2329 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j), kind=wp) + y_kahan
2330 kahan_comp(beta_vars(i))%sf(k, l, j) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j)) - y_kahan
2331 q_beta(beta_vars(i))%sf(k, l, j) = t_kahan
2332 end do
2333 end do
2334 else
2335 do i = 1, nvar
2336 do j = -mapcells, mapcells + 1
2337 q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, j - 1)
2338 kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2339 end do
2340 end do
2341 end if
2342 end if
2343
2344 end subroutine s_beta_periodic
2345
2346 subroutine s_beta_extrapolation(q_beta, bc_dir, bc_loc, k, l, nvar)
2347
2348
2349# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2350#ifdef _CRAYFTN
2351# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2352#if MFC_OpenACC
2353# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2354!$acc routine seq
2355# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2356#elif MFC_OpenMP
2357# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2358
2359# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2360
2361# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2362!$omp declare target device_type(any)
2363# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2364#else
2365# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2366!DIR$ INLINEALWAYS s_beta_extrapolation
2367# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2368#endif
2369# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2370#elif MFC_OpenACC
2371# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2372!$acc routine seq
2373# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2374#elif MFC_OpenMP
2375# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2376
2377# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2378
2379# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2380!$omp declare target device_type(any)
2381# 1482 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2382#endif
2383# 1483 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2384 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2385 integer, intent(in) :: bc_dir, bc_loc
2386 integer, intent(in) :: k, l
2387 integer, intent(in) :: nvar
2388 integer :: j, i
2389
2390 if (bc_dir == 1) then !< x-direction
2391 if (bc_loc == -1) then ! bc%x%beg
2392 do i = 1, nvar
2393 do j = 1, buff_size
2394 q_beta(beta_vars(i))%sf(-j, k, l) = 0._wp
2395 end do
2396 end do
2397 else
2398 do i = 1, nvar
2399 do j = 1, buff_size
2400 q_beta(beta_vars(i))%sf(m + j, k, l) = 0._wp
2401 end do
2402 end do
2403 end if
2404 else if (bc_dir == 2) then !< y-direction
2405 if (bc_loc == -1) then !< bc%y%beg
2406 do i = 1, nvar
2407 do j = 1, buff_size
2408 q_beta(beta_vars(i))%sf(k, -j, l) = 0._wp
2409 end do
2410 end do
2411 else
2412 do i = 1, nvar
2413 do j = 1, buff_size
2414 q_beta(beta_vars(i))%sf(k, n + j, l) = 0._wp
2415 end do
2416 end do
2417 end if
2418 else if (bc_dir == 3) then !< z-direction
2419 if (bc_loc == -1) then !< bc%z%beg
2420 do i = 1, nvar
2421 do j = 1, buff_size
2422 q_beta(beta_vars(i))%sf(k, l, -j) = 0._wp
2423 end do
2424 end do
2425 else !< bc%z%end
2426 do i = 1, nvar
2427 do j = 1, buff_size
2428 q_beta(beta_vars(i))%sf(k, l, p + j) = 0._wp
2429 end do
2430 end do
2431 end if
2432 end if
2433
2434 end subroutine s_beta_extrapolation
2435
2436 subroutine s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
2437
2438
2439# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2440#ifdef _CRAYFTN
2441# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2442#if MFC_OpenACC
2443# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2444!$acc routine seq
2445# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2446#elif MFC_OpenMP
2447# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2448
2449# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2450
2451# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2452!$omp declare target device_type(any)
2453# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2454#else
2455# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2456!DIR$ INLINEALWAYS s_beta_reflective
2457# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2458#endif
2459# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2460#elif MFC_OpenACC
2461# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2462!$acc routine seq
2463# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2464#elif MFC_OpenMP
2465# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2466
2467# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2468
2469# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2470!$omp declare target device_type(any)
2471# 1537 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2472#endif
2473# 1538 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2474 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2475 type(scalar_field), dimension(num_dims + 1), intent(inout) :: kahan_comp
2476 integer, intent(in) :: bc_dir, bc_loc
2477 integer, intent(in) :: k, l
2478 integer, intent(in) :: nvar
2479 integer :: j, i
2480 real(wp) :: y_kahan, t_kahan
2481
2482 ! Reflective BC for void fraction: 1) Fold ghost-cell contributions back onto their mirror interior cells (Kahan) 2) Set
2483 ! ghost cells = mirror of (now-folded) interior values
2484
2485 if (bc_dir == 1) then !< x-direction
2486 if (bc_loc == -1) then ! bc%x%beg
2487 do i = 1, nvar
2488 do j = 1, mapcells + 1
2489 y_kahan = real(q_beta(beta_vars(i))%sf(-j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(-j, k, &
2490 & l) - kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2491 t_kahan = real(q_beta(beta_vars(i))%sf(j - 1, k, l), kind=wp) + y_kahan
2492 kahan_comp(beta_vars(i))%sf(j - 1, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j - 1, k, l)) - y_kahan
2493 q_beta(beta_vars(i))%sf(j - 1, k, l) = t_kahan
2494 end do
2495 do j = 1, mapcells + 1
2496 q_beta(beta_vars(i))%sf(-j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l)
2497 kahan_comp(beta_vars(i))%sf(-j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2498 end do
2499 end do
2500 else !< bc%x%end
2501 do i = 1, nvar
2502 do j = 1, mapcells + 1
2503 y_kahan = real(q_beta(beta_vars(i))%sf(m + j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(m + j, k, &
2504 & l) - kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l)
2505 t_kahan = real(q_beta(beta_vars(i))%sf(m - (j - 1), k, l), kind=wp) + y_kahan
2506 kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l) = (t_kahan - q_beta(beta_vars(i))%sf(m - (j - 1), k, &
2507 & l)) - y_kahan
2508 q_beta(beta_vars(i))%sf(m - (j - 1), k, l) = t_kahan
2509 end do
2510 do j = 1, mapcells + 1
2511 q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(m - (j - 1), k, l)
2512 kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l)
2513 end do
2514 end do
2515 end if
2516 else if (bc_dir == 2) then !< y-direction
2517 if (bc_loc == -1) then !< bc%y%beg
2518 do i = 1, nvar
2519 do j = 1, mapcells + 1
2520 y_kahan = real(q_beta(beta_vars(i))%sf(k, -j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, -j, &
2521 & l) - kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2522 t_kahan = real(q_beta(beta_vars(i))%sf(k, j - 1, l), kind=wp) + y_kahan
2523 kahan_comp(beta_vars(i))%sf(k, j - 1, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j - 1, l)) - y_kahan
2524 q_beta(beta_vars(i))%sf(k, j - 1, l) = t_kahan
2525 end do
2526 do j = 1, mapcells + 1
2527 q_beta(beta_vars(i))%sf(k, -j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l)
2528 kahan_comp(beta_vars(i))%sf(k, -j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2529 end do
2530 end do
2531 else !< bc%y%end
2532 do i = 1, nvar
2533 do j = 1, mapcells + 1
2534 y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, n + j, &
2535 & l) - kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l)
2536 t_kahan = real(q_beta(beta_vars(i))%sf(k, n - (j - 1), l), kind=wp) + y_kahan
2537 kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l) = (t_kahan - q_beta(beta_vars(i))%sf(k, n - (j - 1), &
2538 & l)) - y_kahan
2539 q_beta(beta_vars(i))%sf(k, n - (j - 1), l) = t_kahan
2540 end do
2541 do j = 1, mapcells + 1
2542 q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, n - (j - 1), l)
2543 kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l)
2544 end do
2545 end do
2546 end if
2547 else if (bc_dir == 3) then !< z-direction
2548 if (bc_loc == -1) then !< bc%z%beg
2549 do i = 1, nvar
2550 do j = 1, mapcells + 1
2551 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, -j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2552 & -j) - kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2553 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j - 1), kind=wp) + y_kahan
2554 kahan_comp(beta_vars(i))%sf(k, l, j - 1) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j - 1)) - y_kahan
2555 q_beta(beta_vars(i))%sf(k, l, j - 1) = t_kahan
2556 end do
2557 do j = 1, mapcells + 1
2558 q_beta(beta_vars(i))%sf(k, l, -j) = q_beta(beta_vars(i))%sf(k, l, j - 1)
2559 kahan_comp(beta_vars(i))%sf(k, l, -j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2560 end do
2561 end do
2562 else !< bc%z%end
2563 do i = 1, nvar
2564 do j = 1, mapcells + 1
2565 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2566 & p + j) - kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1))
2567 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, p - (j - 1)), kind=wp) + y_kahan
2568 kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, &
2569 & p - (j - 1))) - y_kahan
2570 q_beta(beta_vars(i))%sf(k, l, p - (j - 1)) = t_kahan
2571 end do
2572 do j = 1, mapcells + 1
2573 q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, p - (j - 1))
2574 kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1))
2575 end do
2576 end do
2577 end if
2578 end if
2579
2580 end subroutine s_beta_reflective
2581
2582end module m_boundary_primitives
m_boundary_primitives
Per-cell noncharacteristic boundary condition primitives applied in the ghost cells.
Definition m_boundary_primitives.fpp.f90:367
m_boundary_primitives::s_slip_wall
subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
Apply slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity ...
Definition m_boundary_primitives.fpp.f90:1072
m_boundary_primitives::bc_vel_ramp
real(wp), dimension(3), public bc_vel_ramp
f_vel_ramp per direction, applied to Dirichlet ghost velocities; set by the time stepper when a ramp ...
Definition m_boundary_primitives.fpp.f90:405
m_boundary_primitives::s_beta_periodic
subroutine s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
Definition m_boundary_primitives.fpp.f90:2238
m_boundary_primitives::dirichlet_from_buffers
logical dirichlet_from_buffers
Definition m_boundary_primitives.fpp.f90:390
m_boundary_primitives::f_vel_ramp
pure real(wp) function, public f_vel_ramp(tau, t0, frac0, t)
Velocity scaling for a GRCBC inflow that is ramping up: unity unless bc_[x,y,z]vel_in_ramp is set,...
Definition m_boundary_primitives.fpp.f90:427
m_boundary_primitives::f_dir_vel
pure real(wp) function f_dir_vel(i, dir)
Ramp factor for variable i of a Dirichlet ghost cell on a dir-normal face: bc_vel_ramp(dir) for veloc...
Definition m_boundary_primitives.fpp.f90:1597
m_boundary_primitives::s_f_igr_periodic
subroutine s_f_igr_periodic(jac_sf, bc_dir, bc_loc, k, l)
Apply periodic boundary conditions to the IGR Jacobian field by copying values from the opposite doma...
Definition m_boundary_primitives.fpp.f90:2005
m_boundary_primitives::s_color_function_periodic
subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l)
Apply periodic boundary conditions to the color function and its divergence fields.
Definition m_boundary_primitives.fpp.f90:1711
m_boundary_primitives::bc_buffers
type(scalar_field), dimension(:,:), allocatable bc_buffers
Definition m_boundary_primitives.fpp.f90:376
m_boundary_primitives::s_f_igr_ghost_cell_extrapolation
subroutine s_f_igr_ghost_cell_extrapolation(jac_sf, bc_dir, bc_loc, k, l)
Extrapolate the IGR Jacobian field into ghost cells by copying boundary values.
Definition m_boundary_primitives.fpp.f90:2161
m_boundary_primitives::s_no_slip_wall
subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
Apply no-slip wall boundary conditions by reflecting and negating all velocity components at the wall...
Definition m_boundary_primitives.fpp.f90:1259
m_boundary_primitives::s_axis
subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l, q_t_sf)
Apply axis boundary conditions for cylindrical coordinates by reflecting values across the axis with ...
Definition m_boundary_primitives.fpp.f90:992
m_boundary_primitives::s_qbmm_extrapolation
subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in)
Extrapolate QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values...
Definition m_boundary_primitives.fpp.f90:1623
m_boundary_primitives::s_color_function_reflective
subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l)
Apply reflective boundary conditions to the color function and its divergence fields.
Definition m_boundary_primitives.fpp.f90:1801
m_boundary_primitives::s_beta_reflective
subroutine s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
Definition m_boundary_primitives.fpp.f90:2437
m_boundary_primitives::s_beta_extrapolation
subroutine s_beta_extrapolation(q_beta, bc_dir, bc_loc, k, l, nvar)
Definition m_boundary_primitives.fpp.f90:2347
m_boundary_primitives::s_f_igr_reflective
subroutine s_f_igr_reflective(jac_sf, bc_dir, bc_loc, k, l)
Apply reflective boundary conditions to the IGR Jacobian field by mirroring values across the boundar...
Definition m_boundary_primitives.fpp.f90:2083
m_boundary_primitives::s_periodic
subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_t_sf)
Apply periodic boundary conditions by copying values from the opposite domain boundary.
Definition m_boundary_primitives.fpp.f90:818
m_boundary_primitives::s_ghost_cell_extrapolation
subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
Fill ghost cells by copying the nearest boundary cell value along the specified direction.
Definition m_boundary_primitives.fpp.f90:457
m_boundary_primitives::s_color_function_ghost_cell_extrapolation
subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l)
Extrapolate the color function and its divergence into ghost cells by copying boundary values.
Definition m_boundary_primitives.fpp.f90:1915
m_boundary_primitives::s_symmetry
subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_t_sf)
Apply reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the nor...
Definition m_boundary_primitives.fpp.f90:579
m_boundary_primitives::s_dirichlet
subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
Apply Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers.
Definition m_boundary_primitives.fpp.f90:1467
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::pi
real(wp), parameter pi
Pi.
Definition m_constants.fpp.f90:16
m_constants::mapcells
integer, parameter mapcells
Number of cells around the bubble where the smoothening function will have effect.
Definition m_constants.fpp.f90:75
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
Global parameters for the post-process: domain geometry, equation of state, and output database setti...
Definition m_global_parameters.fpp.f90:19
m_global_parameters::bc_z
type(int_bounds_info) bc_z
Definition m_global_parameters.fpp.f90:111
m_global_parameters::buff_size
integer buff_size
Number of ghost cells for boundary condition storage.
Definition m_global_parameters.fpp.f90:83
m_global_parameters::bc_y
type(int_bounds_info) bc_y
Definition m_global_parameters.fpp.f90:111
m_global_parameters::bc_x
type(int_bounds_info) bc_x
Definition m_global_parameters.fpp.f90:111
m_global_parameters::z_cc
real(wp), dimension(:), allocatable z_cc
Definition m_global_parameters.fpp.f90:74
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::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_derived_types::scalar_field
Derived type annexing a scalar field (SF).
Definition m_derived_types.fpp.f90:370