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