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