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# 145 "/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# 145 "/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# 145 "/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# 57 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
312
313! Allocate and create GPU device memory
314# 77 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
315
316! Free GPU device memory and deallocate
317# 85 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
318
319! Cray-specific GPU pointer setup for vector fields
320# 109 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
321
322! Cray-specific GPU pointer setup for scalar fields
323# 125 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
324
325! Cray-specific GPU pointer setup for acoustic source spatials
326# 150 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
327
328# 156 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
329
330# 163 "/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
356contains
357
358 !> Fill ghost cells by copying the nearest boundary cell value along the specified direction.
359 subroutine s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
360
361
362# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
363#ifdef _CRAYFTN
364# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
365#if MFC_OpenACC
366# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
367!$acc routine seq
368# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
369#elif MFC_OpenMP
370# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
371
372# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
373
374# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
375!$omp declare target device_type(any)
376# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
377#else
378# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
379!DIR$ INLINEALWAYS s_ghost_cell_extrapolation
380# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
381#endif
382# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
383#elif MFC_OpenACC
384# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
385!$acc routine seq
386# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
387#elif MFC_OpenMP
388# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
389
390# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
391
392# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
393!$omp declare target device_type(any)
394# 26 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
395#endif
396 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
397 integer, intent(in) :: bc_dir, bc_loc
398 integer, intent(in) :: k, l
399 integer :: j, i
400 type(scalar_field), optional, intent(inout) :: q_T_sf
401
402 if (bc_dir == 1) then !< x-direction
403 if (bc_loc == -1) then ! bc_x%beg
404 do i = 1, sys_size
405 do j = 1, buff_size
406 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
407 end do
408 end do
409 if (chemistry .and. present(q_t_sf)) then
410 do j = 1, buff_size
411 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
412 end do
413 end if
414 else !< bc_x%end
415 do i = 1, sys_size
416 do j = 1, buff_size
417 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
418 end do
419 end do
420 if (chemistry .and. present(q_t_sf)) then
421 do j = 1, buff_size
422 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
423 end do
424 end if
425 end if
426 else if (bc_dir == 2) then !< y-direction
427 if (bc_loc == -1) then !< bc_y%beg
428 do i = 1, sys_size
429 do j = 1, buff_size
430 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
431 end do
432 end do
433
434 if (chemistry .and. present(q_t_sf)) then
435 do j = 1, buff_size
436 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
437 end do
438 end if
439 else !< bc_y%end
440 do i = 1, sys_size
441 do j = 1, buff_size
442 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
443 end do
444 end do
445 if (chemistry .and. present(q_t_sf)) then
446 do j = 1, buff_size
447 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
448 end do
449 end if
450 end if
451 else if (bc_dir == 3) then !< z-direction
452 if (bc_loc == -1) then !< bc_z%beg
453 do i = 1, sys_size
454 do j = 1, buff_size
455 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
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, l, -j) = q_t_sf%sf(k, l, 0)
461 end do
462 end if
463 else !< bc_z%end
464 do i = 1, sys_size
465 do j = 1, buff_size
466 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
467 end do
468 end do
469 if (chemistry .and. present(q_t_sf)) then
470 do j = 1, buff_size
471 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
472 end do
473 end if
474 end if
475 end if
476
477 end subroutine s_ghost_cell_extrapolation
478
479 !> Apply reflective (symmetry) boundary conditions by mirroring primitive variables and flipping the normal velocity component.
480 subroutine s_symmetry(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
481
482
483# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
484#if MFC_OpenACC
485# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
486!$acc routine seq
487# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
488#elif MFC_OpenMP
489# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
490
491# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
492
493# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
494!$omp declare target device_type(any)
495# 113 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
496#endif
497 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
498 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
499 integer, intent(in) :: bc_dir, bc_loc
500 integer, intent(in) :: k, l
501 integer :: j, q, i
502 type(scalar_field), optional, intent(inout) :: q_T_sf
503
504 if (bc_dir == 1) then !< x-direction
505 if (bc_loc == -1) then !< bc_x%beg
506 do j = 1, buff_size
507 do i = 1, eqn_idx%cont%end
508 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
509 end do
510
511 q_prim_vf(eqn_idx%mom%beg)%sf(-j, k, l) = -q_prim_vf(eqn_idx%mom%beg)%sf(j - 1, k, l)
512
513 do i = eqn_idx%mom%beg + 1, sys_size
514 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
515 end do
516
517 if (chemistry .and. present(q_t_sf)) then
518 q_t_sf%sf(-j, k, l) = q_t_sf%sf(j - 1, k, l)
519 end if
520
521 if (elasticity) then
522 do i = 1, shear_bc_flip_num
523 q_prim_vf(shear_bc_flip_indices(1, i))%sf(-j, k, l) = -q_prim_vf(shear_bc_flip_indices(1, &
524 & i))%sf(j - 1, k, l)
525 end do
526 end if
527
528 if (hyperelasticity) then
529 q_prim_vf(eqn_idx%xi%beg)%sf(-j, k, l) = -q_prim_vf(eqn_idx%xi%beg)%sf(j - 1, k, l)
530 end if
531 end do
532
533 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
534 do i = 1, nb
535 do q = 1, nnode
536 do j = 1, buff_size
537 pb_in(-j, k, l, q, i) = pb_in(j - 1, k, l, q, i)
538 mv_in(-j, k, l, q, i) = mv_in(j - 1, k, l, q, i)
539 end do
540 end do
541 end do
542 end if
543 else !< bc_x%end
544 do j = 1, buff_size
545 do i = 1, eqn_idx%cont%end
546 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
547 end do
548
549 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)
550
551 do i = eqn_idx%mom%beg + 1, sys_size
552 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
553 end do
554
555 if (chemistry .and. present(q_t_sf)) then
556 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m - (j - 1), k, l)
557 end if
558
559 if (elasticity) then
560 do i = 1, shear_bc_flip_num
561 q_prim_vf(shear_bc_flip_indices(1, i))%sf(m + j, k, l) = -q_prim_vf(shear_bc_flip_indices(1, &
562 & i))%sf(m - (j - 1), k, l)
563 end do
564 end if
565
566 if (hyperelasticity) then
567 q_prim_vf(eqn_idx%xi%beg)%sf(m + j, k, l) = -q_prim_vf(eqn_idx%xi%beg)%sf(m - (j - 1), k, l)
568 end if
569 end do
570 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
571 do i = 1, nb
572 do q = 1, nnode
573 do j = 1, buff_size
574 pb_in(m + j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i)
575 mv_in(m + j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i)
576 end do
577 end do
578 end do
579 end if
580 end if
581 else if (bc_dir == 2) then !< y-direction
582 if (bc_loc == -1) then !< bc_y%beg
583 do j = 1, buff_size
584 do i = 1, eqn_idx%mom%beg
585 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l)
586 end do
587
588 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)
589
590 do i = eqn_idx%mom%beg + 2, sys_size
591 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l)
592 end do
593
594 if (chemistry .and. present(q_t_sf)) then
595 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, j - 1, l)
596 end if
597
598 if (elasticity) then
599 do i = 1, shear_bc_flip_num
600 q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, -j, l) = -q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, &
601 & j - 1, l)
602 end do
603 end if
604
605 if (hyperelasticity) then
606 q_prim_vf(eqn_idx%xi%beg + 1)%sf(k, -j, l) = -q_prim_vf(eqn_idx%xi%beg + 1)%sf(k, j - 1, l)
607 end if
608 end do
609
610 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
611 do i = 1, nb
612 do q = 1, nnode
613 do j = 1, buff_size
614 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l, q, i)
615 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l, q, i)
616 end do
617 end do
618 end do
619 end if
620 else !< bc_y%end
621 do j = 1, buff_size
622 do i = 1, eqn_idx%mom%beg
623 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
624 end do
625
626 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)
627
628 do i = eqn_idx%mom%beg + 2, sys_size
629 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
630 end do
631
632 if (chemistry .and. present(q_t_sf)) then
633 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n - (j - 1), l)
634 end if
635
636 if (elasticity) then
637 do i = 1, shear_bc_flip_num
638 q_prim_vf(shear_bc_flip_indices(2, i))%sf(k, n + j, l) = -q_prim_vf(shear_bc_flip_indices(2, &
639 & i))%sf(k, n - (j - 1), l)
640 end do
641 end if
642
643 if (hyperelasticity) then
644 q_prim_vf(eqn_idx%xi%beg + 1)%sf(k, n + j, l) = -q_prim_vf(eqn_idx%xi%beg + 1)%sf(k, n - (j - 1), l)
645 end if
646 end do
647
648 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
649 do i = 1, nb
650 do q = 1, nnode
651 do j = 1, buff_size
652 pb_in(k, n + j, l, q, i) = pb_in(k, n - (j - 1), l, q, i)
653 mv_in(k, n + j, l, q, i) = mv_in(k, n - (j - 1), l, q, i)
654 end do
655 end do
656 end do
657 end if
658 end if
659 else if (bc_dir == 3) then !< z-direction
660 if (bc_loc == -1) then !< bc_z%beg
661 do j = 1, buff_size
662 do i = 1, eqn_idx%mom%beg + 1
663 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1)
664 end do
665
666 q_prim_vf(eqn_idx%mom%end)%sf(k, l, -j) = -q_prim_vf(eqn_idx%mom%end)%sf(k, l, j - 1)
667
668 do i = eqn_idx%E, sys_size
669 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, j - 1)
670 end do
671
672 if (chemistry .and. present(q_t_sf)) then
673 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, j - 1)
674 end if
675
676 if (elasticity) then
677 do i = 1, shear_bc_flip_num
678 q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, l, -j) = -q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, &
679 & l, j - 1)
680 end do
681 end if
682
683 if (hyperelasticity) then
684 q_prim_vf(eqn_idx%xi%end)%sf(k, l, -j) = -q_prim_vf(eqn_idx%xi%end)%sf(k, l, j - 1)
685 end if
686 end do
687
688 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
689 do i = 1, nb
690 do q = 1, nnode
691 do j = 1, buff_size
692 pb_in(k, l, -j, q, i) = pb_in(k, l, j - 1, q, i)
693 mv_in(k, l, -j, q, i) = mv_in(k, l, j - 1, q, i)
694 end do
695 end do
696 end do
697 end if
698 else !< bc_z%end
699 do j = 1, buff_size
700 do i = 1, eqn_idx%mom%beg + 1
701 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
702 end do
703
704 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))
705
706 do i = eqn_idx%E, sys_size
707 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
708 end do
709
710 if (chemistry .and. present(q_t_sf)) then
711 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p - (j - 1))
712 end if
713
714 if (elasticity) then
715 do i = 1, shear_bc_flip_num
716 q_prim_vf(shear_bc_flip_indices(3, i))%sf(k, l, p + j) = -q_prim_vf(shear_bc_flip_indices(3, &
717 & i))%sf(k, l, p - (j - 1))
718 end do
719 end if
720
721 if (hyperelasticity) then
722 q_prim_vf(eqn_idx%xi%end)%sf(k, l, p + j) = -q_prim_vf(eqn_idx%xi%end)%sf(k, l, p - (j - 1))
723 end if
724 end do
725
726 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
727 do i = 1, nb
728 do q = 1, nnode
729 do j = 1, buff_size
730 pb_in(k, l, p + j, q, i) = pb_in(k, l, p - (j - 1), q, i)
731 mv_in(k, l, p + j, q, i) = mv_in(k, l, p - (j - 1), q, i)
732 end do
733 end do
734 end do
735 end if
736 end if
737 end if
738
739 end subroutine s_symmetry
740
741 !> Apply periodic boundary conditions by copying values from the opposite domain boundary.
742 subroutine s_periodic(q_prim_vf, bc_dir, bc_loc, k, l, pb_in, mv_in, q_T_sf)
743
744
745# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
746#if MFC_OpenACC
747# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
748!$acc routine seq
749# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
750#elif MFC_OpenMP
751# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
752
753# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
754
755# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
756!$omp declare target device_type(any)
757# 361 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
758#endif
759 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
760 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
761 integer, intent(in) :: bc_dir, bc_loc
762 integer, intent(in) :: k, l
763 integer :: j, q, i
764 type(scalar_field), optional, intent(inout) :: q_T_sf
765
766 if (bc_dir == 1) then !< x-direction
767 if (bc_loc == -1) then !< bc_x%beg
768 do i = 1, sys_size
769 do j = 1, buff_size
770 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(m - (j - 1), k, l)
771 end do
772 end do
773
774 if (chemistry .and. present(q_t_sf)) then
775 do j = 1, buff_size
776 q_t_sf%sf(-j, k, l) = q_t_sf%sf(m - (j - 1), k, l)
777 end do
778 end if
779
780 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
781 do i = 1, nb
782 do q = 1, nnode
783 do j = 1, buff_size
784 pb_in(-j, k, l, q, i) = pb_in(m - (j - 1), k, l, q, i)
785 mv_in(-j, k, l, q, i) = mv_in(m - (j - 1), k, l, q, i)
786 end do
787 end do
788 end do
789 end if
790 else !< bc_x%end
791 do i = 1, sys_size
792 do j = 1, buff_size
793 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(j - 1, k, l)
794 end do
795 end do
796
797 if (chemistry .and. present(q_t_sf)) then
798 do j = 1, buff_size
799 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(j - 1, k, l)
800 end do
801 end if
802
803 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
804 do i = 1, nb
805 do q = 1, nnode
806 do j = 1, buff_size
807 pb_in(m + j, k, l, q, i) = pb_in(j - 1, k, l, q, i)
808 mv_in(m + j, k, l, q, i) = mv_in(j - 1, k, l, q, i)
809 end do
810 end do
811 end do
812 end if
813 end if
814 else if (bc_dir == 2) then !< y-direction
815 if (bc_loc == -1) then !< bc_y%beg
816 do i = 1, sys_size
817 do j = 1, buff_size
818 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, n - (j - 1), l)
819 end do
820 end do
821
822 if (chemistry .and. present(q_t_sf)) then
823 do j = 1, buff_size
824 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, n - (j - 1), l)
825 end do
826 end if
827
828 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
829 do i = 1, nb
830 do q = 1, nnode
831 do j = 1, buff_size
832 pb_in(k, -j, l, q, i) = pb_in(k, n - (j - 1), l, q, i)
833 mv_in(k, -j, l, q, i) = mv_in(k, n - (j - 1), l, q, i)
834 end do
835 end do
836 end do
837 end if
838 else !< bc_y%end
839 do i = 1, sys_size
840 do j = 1, buff_size
841 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, j - 1, l)
842 end do
843 end do
844
845 if (chemistry .and. present(q_t_sf)) then
846 do j = 1, buff_size
847 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, j - 1, l)
848 end do
849 end if
850
851 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
852 do i = 1, nb
853 do q = 1, nnode
854 do j = 1, buff_size
855 pb_in(k, n + j, l, q, i) = pb_in(k, (j - 1), l, q, i)
856 mv_in(k, n + j, l, q, i) = mv_in(k, (j - 1), l, q, i)
857 end do
858 end do
859 end do
860 end if
861 end if
862 else if (bc_dir == 3) then !< z-direction
863 if (bc_loc == -1) then !< bc_z%beg
864 do i = 1, sys_size
865 do j = 1, buff_size
866 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, p - (j - 1))
867 end do
868 end do
869
870 if (chemistry .and. present(q_t_sf)) then
871 do j = 1, buff_size
872 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, p - (j - 1))
873 end do
874 end if
875
876 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
877 do i = 1, nb
878 do q = 1, nnode
879 do j = 1, buff_size
880 pb_in(k, l, -j, q, i) = pb_in(k, l, p - (j - 1), q, i)
881 mv_in(k, l, -j, q, i) = mv_in(k, l, p - (j - 1), q, i)
882 end do
883 end do
884 end do
885 end if
886 else !< bc_z%end
887 do i = 1, sys_size
888 do j = 1, buff_size
889 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, j - 1)
890 end do
891 end do
892
893 if (chemistry .and. present(q_t_sf)) then
894 do j = 1, buff_size
895 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, j - 1)
896 end do
897 end if
898
899 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
900 do i = 1, nb
901 do q = 1, nnode
902 do j = 1, buff_size
903 pb_in(k, l, p + j, q, i) = pb_in(k, l, j - 1, q, i)
904 mv_in(k, l, p + j, q, i) = mv_in(k, l, j - 1, q, i)
905 end do
906 end do
907 end do
908 end if
909 end if
910 end if
911
912 end subroutine s_periodic
913
914 !> Apply axis boundary conditions for cylindrical coordinates by reflecting values across the axis with azimuthal phase shift.
915 subroutine s_axis(q_prim_vf, pb_in, mv_in, k, l)
916
917
918# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
919#if MFC_OpenACC
920# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
921!$acc routine seq
922# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
923#elif MFC_OpenMP
924# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
925
926# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
927
928# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
929!$omp declare target device_type(any)
930# 520 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
931#endif
932 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
933 real(stp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), optional, intent(inout) :: pb_in, mv_in
934 integer, intent(in) :: k, l
935 integer :: j, q, i
936
937 do j = 1, buff_size
938 if (z_cc(l) < pi) then
939 do i = 1, eqn_idx%mom%beg
940 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2))
941 end do
942
943 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))
944
945 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))
946
947 do i = eqn_idx%E, sys_size
948 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l + ((p + 1)/2))
949 end do
950 else
951 do i = 1, eqn_idx%mom%beg
952 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2))
953 end do
954
955 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))
956
957 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))
958
959 do i = eqn_idx%E, sys_size
960 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, j - 1, l - ((p + 1)/2))
961 end do
962 end if
963 end do
964
965 if (qbmm .and. .not. polytropic .and. present(pb_in) .and. present(mv_in)) then
966 do i = 1, nb
967 do q = 1, nnode
968 do j = 1, buff_size
969 if (z_cc(l) < pi) then
970 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l + ((p + 1)/2), q, i)
971 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l + ((p + 1)/2), q, i)
972 else
973 pb_in(k, -j, l, q, i) = pb_in(k, j - 1, l - ((p + 1)/2), q, i)
974 mv_in(k, -j, l, q, i) = mv_in(k, j - 1, l - ((p + 1)/2), q, i)
975 end if
976 end do
977 end do
978 end do
979 end if
980
981 end subroutine s_axis
982
983 !> Apply slip wall boundary conditions by extrapolating scalars and reflecting the wall-normal velocity component.
984 subroutine s_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
985
986
987# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
988#ifdef _CRAYFTN
989# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
990#if MFC_OpenACC
991# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
992!$acc routine seq
993# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
994#elif MFC_OpenMP
995# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
996
997# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
998
999# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1000!$omp declare target device_type(any)
1001# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1002#else
1003# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1004!DIR$ INLINEALWAYS s_slip_wall
1005# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1006#endif
1007# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1008#elif MFC_OpenACC
1009# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1010!$acc routine seq
1011# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1012#elif MFC_OpenMP
1013# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1014
1015# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1016
1017# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1018!$omp declare target device_type(any)
1019# 575 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1020#endif
1021 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1022 integer, intent(in) :: bc_dir, bc_loc
1023 integer, intent(in) :: k, l
1024 integer :: j, i
1025 type(scalar_field), optional, intent(inout) :: q_T_sf
1026
1027 if (bc_dir == 1) then !< x-direction
1028 if (bc_loc == -1) then !< bc_x%beg
1029 do i = 1, sys_size
1030 do j = 1, buff_size
1031 if (i == eqn_idx%mom%beg) then
1032 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1
1033 else
1034 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
1035 end if
1036 end do
1037 end do
1038
1039 if (chemistry .and. present(q_t_sf)) then
1040 if (bc_x%isothermal_in) then
1041 do j = 1, buff_size
1042 q_t_sf%sf(-j, k, l) = 2._wp*bc_x%Twall_in - q_t_sf%sf(j - 1, k, l)
1043 end do
1044 else
1045 do j = 1, buff_size
1046 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
1047 end do
1048 end if
1049 end if
1050 else !< bc_x%end
1051 do i = 1, sys_size
1052 do j = 1, buff_size
1053 if (i == eqn_idx%mom%beg) then
1054 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1
1055 else
1056 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
1057 end if
1058 end do
1059 end do
1060
1061 if (chemistry .and. present(q_t_sf)) then
1062 if (bc_x%isothermal_out) then
1063 do j = 1, buff_size
1064 q_t_sf%sf(m + j, k, l) = 2._wp*bc_x%Twall_out - q_t_sf%sf(m - (j - 1), k, l)
1065 end do
1066 else
1067 do j = 1, buff_size
1068 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
1069 end do
1070 end if
1071 end if
1072 end if
1073 else if (bc_dir == 2) then !< y-direction
1074 if (bc_loc == -1) then !< bc_y%beg
1075 do i = 1, sys_size
1076 do j = 1, buff_size
1077 if (i == eqn_idx%mom%beg + 1) then
1078 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2
1079 else
1080 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
1081 end if
1082 end do
1083 end do
1084
1085 if (chemistry .and. present(q_t_sf)) then
1086 if (bc_y%isothermal_in) then
1087 do j = 1, buff_size
1088 q_t_sf%sf(k, -j, l) = 2._wp*bc_y%Twall_in - q_t_sf%sf(k, j - 1, l)
1089 end do
1090 else
1091 do j = 1, buff_size
1092 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
1093 end do
1094 end if
1095 end if
1096 else !< bc_y%end
1097 do i = 1, sys_size
1098 do j = 1, buff_size
1099 if (i == eqn_idx%mom%beg + 1) then
1100 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2
1101 else
1102 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
1103 end if
1104 end do
1105 end do
1106
1107 if (chemistry .and. present(q_t_sf)) then
1108 if (bc_y%isothermal_out) then
1109 do j = 1, buff_size
1110 q_t_sf%sf(k, n + j, l) = 2._wp*bc_y%Twall_out - q_t_sf%sf(k, n - (j - 1), l)
1111 end do
1112 else
1113 do j = 1, buff_size
1114 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
1115 end do
1116 end if
1117 end if
1118 end if
1119 else if (bc_dir == 3) then !< z-direction
1120 if (bc_loc == -1) then !< bc_z%beg
1121 do i = 1, sys_size
1122 do j = 1, buff_size
1123 if (i == eqn_idx%mom%end) then
1124 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3
1125 else
1126 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
1127 end if
1128 end do
1129 end do
1130
1131 if (chemistry .and. present(q_t_sf)) then
1132 if (bc_z%isothermal_in) then
1133 do j = 1, buff_size
1134 q_t_sf%sf(k, l, -j) = 2._wp*bc_z%Twall_in - q_t_sf%sf(k, l, j - 1)
1135 end do
1136 else
1137 do j = 1, buff_size
1138 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, 0)
1139 end do
1140 end if
1141 end if
1142 else !< bc_z%end
1143 do i = 1, sys_size
1144 do j = 1, buff_size
1145 if (i == eqn_idx%mom%end) then
1146 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3
1147 else
1148 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
1149 end if
1150 end do
1151 end do
1152
1153 if (chemistry .and. present(q_t_sf)) then
1154 if (bc_z%isothermal_out) then
1155 do j = 1, buff_size
1156 q_t_sf%sf(k, l, p + j) = 2._wp*bc_z%Twall_out - q_t_sf%sf(k, l, p - (j - 1))
1157 end do
1158 else
1159 do j = 1, buff_size
1160 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
1161 end do
1162 end if
1163 end if
1164 end if
1165 end if
1166
1167 end subroutine s_slip_wall
1168
1169 !> Apply no-slip wall boundary conditions by reflecting and negating all velocity components at the wall.
1170 subroutine s_no_slip_wall(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
1171
1172
1173# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1174#ifdef _CRAYFTN
1175# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1176#if MFC_OpenACC
1177# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1178!$acc routine seq
1179# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1180#elif MFC_OpenMP
1181# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1182
1183# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1184
1185# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1186!$omp declare target device_type(any)
1187# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1188#else
1189# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1190!DIR$ INLINEALWAYS s_no_slip_wall
1191# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1192#endif
1193# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1194#elif MFC_OpenACC
1195# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1196!$acc routine seq
1197# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1198#elif MFC_OpenMP
1199# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1200
1201# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1202
1203# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1204!$omp declare target device_type(any)
1205# 727 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1206#endif
1207
1208 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1209 integer, intent(in) :: bc_dir, bc_loc
1210 integer, intent(in) :: k, l
1211 integer :: j, i
1212 type(scalar_field), optional, intent(inout) :: q_T_sf
1213
1214 if (bc_dir == 1) then !< x-direction
1215 if (bc_loc == -1) then !< bc_x%beg
1216 do i = 1, sys_size
1217 do j = 1, buff_size
1218 if (i == eqn_idx%mom%beg) then
1219 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb1
1220 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1221 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb2
1222 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1223 q_prim_vf(i)%sf(-j, k, l) = -q_prim_vf(i)%sf(j - 1, k, l) + 2._wp*bc_x%vb3
1224 else
1225 q_prim_vf(i)%sf(-j, k, l) = q_prim_vf(i)%sf(0, k, l)
1226 end if
1227 end do
1228 end do
1229
1230 if (chemistry .and. present(q_t_sf)) then
1231 if (bc_x%isothermal_in) then
1232 do j = 1, buff_size
1233 q_t_sf%sf(-j, k, l) = 2._wp*bc_x%Twall_in - q_t_sf%sf(j - 1, k, l)
1234 end do
1235 else
1236 do j = 1, buff_size
1237 q_t_sf%sf(-j, k, l) = q_t_sf%sf(0, k, l)
1238 end do
1239 end if
1240 end if
1241 else !< bc_x%end
1242 do i = 1, sys_size
1243 do j = 1, buff_size
1244 if (i == eqn_idx%mom%beg) then
1245 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve1
1246 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1247 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve2
1248 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1249 q_prim_vf(i)%sf(m + j, k, l) = -q_prim_vf(i)%sf(m - (j - 1), k, l) + 2._wp*bc_x%ve3
1250 else
1251 q_prim_vf(i)%sf(m + j, k, l) = q_prim_vf(i)%sf(m, k, l)
1252 end if
1253 end do
1254 end do
1255
1256 if (chemistry .and. present(q_t_sf)) then
1257 if (bc_x%isothermal_out) then
1258 do j = 1, buff_size
1259 q_t_sf%sf(m + j, k, l) = 2._wp*bc_x%Twall_out - q_t_sf%sf(m - (j - 1), k, l)
1260 end do
1261 else
1262 do j = 1, buff_size
1263 q_t_sf%sf(m + j, k, l) = q_t_sf%sf(m, k, l)
1264 end do
1265 end if
1266 end if
1267 end if
1268 else if (bc_dir == 2) then !< y-direction
1269 if (bc_loc == -1) then !< bc_y%beg
1270 do i = 1, sys_size
1271 do j = 1, buff_size
1272 if (i == eqn_idx%mom%beg) then
1273 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb1
1274 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1275 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb2
1276 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1277 q_prim_vf(i)%sf(k, -j, l) = -q_prim_vf(i)%sf(k, j - 1, l) + 2._wp*bc_y%vb3
1278 else
1279 q_prim_vf(i)%sf(k, -j, l) = q_prim_vf(i)%sf(k, 0, l)
1280 end if
1281 end do
1282 end do
1283 if (chemistry .and. present(q_t_sf)) then
1284 if (bc_y%isothermal_in) then
1285 do j = 1, buff_size
1286 q_t_sf%sf(k, -j, l) = 2._wp*bc_y%Twall_in - q_t_sf%sf(k, j - 1, l)
1287 end do
1288 else
1289 do j = 1, buff_size
1290 q_t_sf%sf(k, -j, l) = q_t_sf%sf(k, 0, l)
1291 end do
1292 end if
1293 end if
1294 else !< bc_y%end
1295 do i = 1, sys_size
1296 do j = 1, buff_size
1297 if (i == eqn_idx%mom%beg) then
1298 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve1
1299 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1300 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve2
1301 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1302 q_prim_vf(i)%sf(k, n + j, l) = -q_prim_vf(i)%sf(k, n - (j - 1), l) + 2._wp*bc_y%ve3
1303 else
1304 q_prim_vf(i)%sf(k, n + j, l) = q_prim_vf(i)%sf(k, n, l)
1305 end if
1306 end do
1307 end do
1308 if (chemistry .and. present(q_t_sf)) then
1309 if (bc_y%isothermal_out) then
1310 do j = 1, buff_size
1311 q_t_sf%sf(k, n + j, l) = 2._wp*bc_y%Twall_out - q_t_sf%sf(k, n - (j - 1), l)
1312 end do
1313 else
1314 do j = 1, buff_size
1315 q_t_sf%sf(k, n + j, l) = q_t_sf%sf(k, n, l)
1316 end do
1317 end if
1318 end if
1319 end if
1320 else if (bc_dir == 3) then !< z-direction
1321 if (bc_loc == -1) then !< bc_z%beg
1322 do i = 1, sys_size
1323 do j = 1, buff_size
1324 if (i == eqn_idx%mom%beg) then
1325 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb1
1326 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1327 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb2
1328 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1329 q_prim_vf(i)%sf(k, l, -j) = -q_prim_vf(i)%sf(k, l, j - 1) + 2._wp*bc_z%vb3
1330 else
1331 q_prim_vf(i)%sf(k, l, -j) = q_prim_vf(i)%sf(k, l, 0)
1332 end if
1333 end do
1334 end do
1335 if (chemistry .and. present(q_t_sf)) then
1336 if (bc_z%isothermal_in) then
1337 do j = 1, buff_size
1338 q_t_sf%sf(k, l, -j) = 2._wp*bc_z%Twall_in - q_t_sf%sf(k, l, j - 1)
1339 end do
1340 else
1341 do j = 1, buff_size
1342 q_t_sf%sf(k, l, -j) = q_t_sf%sf(k, l, 0)
1343 end do
1344 end if
1345 end if
1346 else !< bc_z%end
1347 do i = 1, sys_size
1348 do j = 1, buff_size
1349 if (i == eqn_idx%mom%beg) then
1350 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve1
1351 else if (i == eqn_idx%mom%beg + 1 .and. num_dims > 1) then
1352 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve2
1353 else if (i == eqn_idx%mom%beg + 2 .and. num_dims > 2) then
1354 q_prim_vf(i)%sf(k, l, p + j) = -q_prim_vf(i)%sf(k, l, p - (j - 1)) + 2._wp*bc_z%ve3
1355 else
1356 q_prim_vf(i)%sf(k, l, p + j) = q_prim_vf(i)%sf(k, l, p)
1357 end if
1358 end do
1359 end do
1360 if (chemistry .and. present(q_t_sf)) then
1361 if (bc_z%isothermal_out) then
1362 do j = 1, buff_size
1363 q_t_sf%sf(k, l, p + j) = 2._wp*bc_z%Twall_out - q_t_sf%sf(k, l, p - (j - 1))
1364 end do
1365 else
1366 do j = 1, buff_size
1367 q_t_sf%sf(k, l, p + j) = q_t_sf%sf(k, l, p)
1368 end do
1369 end if
1370 end if
1371 end if
1372 end if
1373
1374 end subroutine s_no_slip_wall
1375
1376 !> Apply Dirichlet boundary conditions by prescribing ghost cell values from stored boundary buffers.
1377 subroutine s_dirichlet(q_prim_vf, bc_dir, bc_loc, k, l, q_T_sf)
1378
1379
1380# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1381#ifdef _CRAYFTN
1382# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1383#if MFC_OpenACC
1384# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1385!$acc routine seq
1386# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1387#elif MFC_OpenMP
1388# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1389
1390# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1391
1392# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1393!$omp declare target device_type(any)
1394# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1395#else
1396# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1397!DIR$ INLINEALWAYS s_dirichlet
1398# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1399#endif
1400# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1401#elif MFC_OpenACC
1402# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1403!$acc routine seq
1404# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1405#elif MFC_OpenMP
1406# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1407
1408# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1409
1410# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1411!$omp declare target device_type(any)
1412# 900 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1413#endif
1414 type(scalar_field), dimension(sys_size), intent(inout) :: q_prim_vf
1415 integer, intent(in) :: bc_dir, bc_loc
1416 integer, intent(in) :: k, l
1417 integer :: j, i
1418 type(scalar_field), optional, intent(inout) :: q_T_sf
1419
1420#ifdef MFC_SIMULATION
1421 if (bc_dir == 1) then !< x-direction
1422 if (bc_loc == -1) then ! bc_x%beg
1423 do i = 1, sys_size
1424 do j = 1, buff_size
1425 q_prim_vf(i)%sf(-j, k, l) = bc_buffers(1, 1)%sf(i, k, l)
1426 end do
1427 end do
1428 if (chemistry .and. present(q_t_sf)) then
1429 do j = 1, buff_size
1430 q_t_sf%sf(-j, k, l) = bc_buffers(1, 1)%sf(sys_size + 1, k, l)
1431 end do
1432 end if
1433 else !< bc_x%end
1434 do i = 1, sys_size
1435 do j = 1, buff_size
1436 q_prim_vf(i)%sf(m + j, k, l) = bc_buffers(1, 2)%sf(i, k, l)
1437 end do
1438 end do
1439 if (chemistry .and. present(q_t_sf)) then
1440 do j = 1, buff_size
1441 q_t_sf%sf(m + j, k, l) = bc_buffers(1, 2)%sf(sys_size + 1, k, l)
1442 end do
1443 end if
1444 end if
1445 else if (bc_dir == 2) then !< y-direction
1446# 934 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1447 if (bc_loc == -1) then !< bc_y%beg
1448 do i = 1, sys_size
1449 do j = 1, buff_size
1450 q_prim_vf(i)%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, i, l)
1451 end do
1452 end do
1453 if (chemistry .and. present(q_t_sf)) then
1454 do j = 1, buff_size
1455 q_t_sf%sf(k, -j, l) = bc_buffers(2, 1)%sf(k, sys_size + 1, l)
1456 end do
1457 end if
1458 else !< bc_y%end
1459 do i = 1, sys_size
1460 do j = 1, buff_size
1461 q_prim_vf(i)%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, i, l)
1462 end do
1463 end do
1464 if (chemistry .and. present(q_t_sf)) then
1465 do j = 1, buff_size
1466 q_t_sf%sf(k, n + j, l) = bc_buffers(2, 2)%sf(k, sys_size + 1, l)
1467 end do
1468 end if
1469 end if
1470# 958 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1471 else if (bc_dir == 3) then !< z-direction
1472# 960 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1473 if (bc_loc == -1) then !< bc_z%beg
1474 do i = 1, sys_size
1475 do j = 1, buff_size
1476 q_prim_vf(i)%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, i)
1477 end do
1478 end do
1479 if (chemistry .and. present(q_t_sf)) then
1480 do j = 1, buff_size
1481 q_t_sf%sf(k, l, -j) = bc_buffers(3, 1)%sf(k, l, sys_size + 1)
1482 end do
1483 end if
1484 else !< bc_z%end
1485 do i = 1, sys_size
1486 do j = 1, buff_size
1487 q_prim_vf(i)%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, i)
1488 end do
1489 end do
1490 if (chemistry .and. present(q_t_sf)) then
1491 do j = 1, buff_size
1492 q_t_sf%sf(k, l, p + j) = bc_buffers(3, 2)%sf(k, l, sys_size + 1)
1493 end do
1494 end if
1495 end if
1496# 984 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1497 end if
1498#else
1499 call s_ghost_cell_extrapolation(q_prim_vf, bc_dir, bc_loc, k, l, q_t_sf)
1500#endif
1501
1502 end subroutine s_dirichlet
1503
1504 !> Extrapolate QBMM bubble pressure and mass-vapor variables into ghost cells by copying boundary values.
1505 subroutine s_qbmm_extrapolation(bc_dir, bc_loc, k, l, pb_in, mv_in)
1506
1507
1508# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1509#if MFC_OpenACC
1510# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1511!$acc routine seq
1512# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1513#elif MFC_OpenMP
1514# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1515
1516# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1517
1518# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1519!$omp declare target device_type(any)
1520# 994 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1521#endif
1522 real(stp), optional, dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:,1:), intent(inout) :: pb_in, mv_in
1523 integer, intent(in) :: bc_dir, bc_loc
1524 integer, intent(in) :: k, l
1525 integer :: j, q, i
1526
1527 if (bc_dir == 1) then !< x-direction
1528 if (bc_loc == -1) then ! bc_x%beg
1529 do i = 1, nb
1530 do q = 1, nnode
1531 do j = 1, buff_size
1532 pb_in(-j, k, l, q, i) = pb_in(0, k, l, q, i)
1533 mv_in(-j, k, l, q, i) = mv_in(0, k, l, q, i)
1534 end do
1535 end do
1536 end do
1537 else !< bc_x%end
1538 do i = 1, nb
1539 do q = 1, nnode
1540 do j = 1, buff_size
1541 pb_in(m + j, k, l, q, i) = pb_in(m, k, l, q, i)
1542 mv_in(m + j, k, l, q, i) = mv_in(m, k, l, q, i)
1543 end do
1544 end do
1545 end do
1546 end if
1547 else if (bc_dir == 2) then !< y-direction
1548 if (bc_loc == -1) then !< bc_y%beg
1549 do i = 1, nb
1550 do q = 1, nnode
1551 do j = 1, buff_size
1552 pb_in(k, -j, l, q, i) = pb_in(k, 0, l, q, i)
1553 mv_in(k, -j, l, q, i) = mv_in(k, 0, l, q, i)
1554 end do
1555 end do
1556 end do
1557 else !< bc_y%end
1558 do i = 1, nb
1559 do q = 1, nnode
1560 do j = 1, buff_size
1561 pb_in(k, n + j, l, q, i) = pb_in(k, n, l, q, i)
1562 mv_in(k, n + j, l, q, i) = mv_in(k, n, l, q, i)
1563 end do
1564 end do
1565 end do
1566 end if
1567 else if (bc_dir == 3) then !< z-direction
1568 if (bc_loc == -1) then !< bc_z%beg
1569 do i = 1, nb
1570 do q = 1, nnode
1571 do j = 1, buff_size
1572 pb_in(k, l, -j, q, i) = pb_in(k, l, 0, q, i)
1573 mv_in(k, l, -j, q, i) = mv_in(k, l, 0, q, i)
1574 end do
1575 end do
1576 end do
1577 else !< bc_z%end
1578 do i = 1, nb
1579 do q = 1, nnode
1580 do j = 1, buff_size
1581 pb_in(k, l, p + j, q, i) = pb_in(k, l, p, q, i)
1582 mv_in(k, l, p + j, q, i) = mv_in(k, l, p, q, i)
1583 end do
1584 end do
1585 end do
1586 end if
1587 end if
1588
1589 end subroutine s_qbmm_extrapolation
1590
1591 !> Apply periodic boundary conditions to the color function and its divergence fields.
1592 subroutine s_color_function_periodic(c_divs, bc_dir, bc_loc, k, l)
1593
1594
1595# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1596#ifdef _CRAYFTN
1597# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1598#if MFC_OpenACC
1599# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1600!$acc routine seq
1601# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1602#elif MFC_OpenMP
1603# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1604
1605# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1606
1607# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1608!$omp declare target device_type(any)
1609# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1610#else
1611# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1612!DIR$ INLINEALWAYS s_color_function_periodic
1613# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1614#endif
1615# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1616#elif MFC_OpenACC
1617# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1618!$acc routine seq
1619# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1620#elif MFC_OpenMP
1621# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1622
1623# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1624
1625# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1626!$omp declare target device_type(any)
1627# 1067 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1628#endif
1629 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1630 integer, intent(in) :: bc_dir, bc_loc
1631 integer, intent(in) :: k, l
1632 integer :: j, i
1633
1634 if (bc_dir == 1) then !< x-direction
1635 if (bc_loc == -1) then ! bc_x%beg
1636 do i = 1, num_dims + 1
1637 do j = 1, buff_size
1638 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(m - (j - 1), k, l)
1639 end do
1640 end do
1641 else !< bc_x%end
1642 do i = 1, num_dims + 1
1643 do j = 1, buff_size
1644 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(j - 1, k, l)
1645 end do
1646 end do
1647 end if
1648 else if (bc_dir == 2) then !< y-direction
1649 if (bc_loc == -1) then !< bc_y%beg
1650 do i = 1, num_dims + 1
1651 do j = 1, buff_size
1652 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, n - (j - 1), l)
1653 end do
1654 end do
1655 else !< bc_y%end
1656 do i = 1, num_dims + 1
1657 do j = 1, buff_size
1658 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, j - 1, l)
1659 end do
1660 end do
1661 end if
1662 else if (bc_dir == 3) then !< z-direction
1663 if (bc_loc == -1) then !< bc_z%beg
1664 do i = 1, num_dims + 1
1665 do j = 1, buff_size
1666 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, p - (j - 1))
1667 end do
1668 end do
1669 else !< bc_z%end
1670 do i = 1, num_dims + 1
1671 do j = 1, buff_size
1672 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, j - 1)
1673 end do
1674 end do
1675 end if
1676 end if
1677
1678 end subroutine s_color_function_periodic
1679
1680 !> Apply reflective boundary conditions to the color function and its divergence fields.
1681 subroutine s_color_function_reflective(c_divs, bc_dir, bc_loc, k, l)
1682
1683
1684# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1685#ifdef _CRAYFTN
1686# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1687#if MFC_OpenACC
1688# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1689!$acc routine seq
1690# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1691#elif MFC_OpenMP
1692# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1693
1694# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1695
1696# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1697!$omp declare target device_type(any)
1698# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1699#else
1700# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1701!DIR$ INLINEALWAYS s_color_function_reflective
1702# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1703#endif
1704# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1705#elif MFC_OpenACC
1706# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1707!$acc routine seq
1708# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1709#elif MFC_OpenMP
1710# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1711
1712# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1713
1714# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1715!$omp declare target device_type(any)
1716# 1122 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1717#endif
1718 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1719 integer, intent(in) :: bc_dir, bc_loc
1720 integer, intent(in) :: k, l
1721 integer :: j, i
1722
1723 if (bc_dir == 1) then !< x-direction
1724 if (bc_loc == -1) then ! bc_x%beg
1725 do i = 1, num_dims + 1
1726 do j = 1, buff_size
1727 if (i == bc_dir) then
1728 c_divs(i)%sf(-j, k, l) = -c_divs(i)%sf(j - 1, k, l)
1729 else
1730 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(j - 1, k, l)
1731 end if
1732 end do
1733 end do
1734 else !< bc_x%end
1735 do i = 1, num_dims + 1
1736 do j = 1, buff_size
1737 if (i == bc_dir) then
1738 c_divs(i)%sf(m + j, k, l) = -c_divs(i)%sf(m - (j - 1), k, l)
1739 else
1740 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(m - (j - 1), k, l)
1741 end if
1742 end do
1743 end do
1744 end if
1745 else if (bc_dir == 2) then !< y-direction
1746 if (bc_loc == -1) then !< bc_y%beg
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, -j, l) = -c_divs(i)%sf(k, j - 1, l)
1751 else
1752 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, j - 1, l)
1753 end if
1754 end do
1755 end do
1756 else !< bc_y%end
1757 do i = 1, num_dims + 1
1758 do j = 1, buff_size
1759 if (i == bc_dir) then
1760 c_divs(i)%sf(k, n + j, l) = -c_divs(i)%sf(k, n - (j - 1), l)
1761 else
1762 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, n - (j - 1), l)
1763 end if
1764 end do
1765 end do
1766 end if
1767 else if (bc_dir == 3) then !< z-direction
1768 if (bc_loc == -1) then !< bc_z%beg
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, -j) = -c_divs(i)%sf(k, l, j - 1)
1773 else
1774 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, j - 1)
1775 end if
1776 end do
1777 end do
1778 else !< bc_z%end
1779 do i = 1, num_dims + 1
1780 do j = 1, buff_size
1781 if (i == bc_dir) then
1782 c_divs(i)%sf(k, l, p + j) = -c_divs(i)%sf(k, l, p - (j - 1))
1783 else
1784 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, p - (j - 1))
1785 end if
1786 end do
1787 end do
1788 end if
1789 end if
1790
1791 end subroutine s_color_function_reflective
1792
1793 !> Extrapolate the color function and its divergence into ghost cells by copying boundary values.
1794 subroutine s_color_function_ghost_cell_extrapolation(c_divs, bc_dir, bc_loc, k, l)
1795
1796
1797# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1798#ifdef _CRAYFTN
1799# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1800#if MFC_OpenACC
1801# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1802!$acc routine seq
1803# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1804#elif MFC_OpenMP
1805# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1806
1807# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1808
1809# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1810!$omp declare target device_type(any)
1811# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1812#else
1813# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1814!DIR$ INLINEALWAYS s_color_function_ghost_cell_extrapolation
1815# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1816#endif
1817# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1818#elif MFC_OpenACC
1819# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1820!$acc routine seq
1821# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1822#elif MFC_OpenMP
1823# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1824
1825# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1826
1827# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1828!$omp declare target device_type(any)
1829# 1201 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1830#endif
1831 type(scalar_field), dimension(num_dims + 1), intent(inout) :: c_divs
1832 integer, intent(in) :: bc_dir, bc_loc
1833 integer, intent(in) :: k, l
1834 integer :: j, i
1835
1836 if (bc_dir == 1) then !< x-direction
1837 if (bc_loc == -1) then ! bc_x%beg
1838 do i = 1, num_dims + 1
1839 do j = 1, buff_size
1840 c_divs(i)%sf(-j, k, l) = c_divs(i)%sf(0, k, l)
1841 end do
1842 end do
1843 else !< bc_x%end
1844 do i = 1, num_dims + 1
1845 do j = 1, buff_size
1846 c_divs(i)%sf(m + j, k, l) = c_divs(i)%sf(m, k, l)
1847 end do
1848 end do
1849 end if
1850 else if (bc_dir == 2) then !< y-direction
1851 if (bc_loc == -1) then !< bc_y%beg
1852 do i = 1, num_dims + 1
1853 do j = 1, buff_size
1854 c_divs(i)%sf(k, -j, l) = c_divs(i)%sf(k, 0, l)
1855 end do
1856 end do
1857 else !< bc_y%end
1858 do i = 1, num_dims + 1
1859 do j = 1, buff_size
1860 c_divs(i)%sf(k, n + j, l) = c_divs(i)%sf(k, n, l)
1861 end do
1862 end do
1863 end if
1864 else if (bc_dir == 3) then !< z-direction
1865 if (bc_loc == -1) then !< bc_z%beg
1866 do i = 1, num_dims + 1
1867 do j = 1, buff_size
1868 c_divs(i)%sf(k, l, -j) = c_divs(i)%sf(k, l, 0)
1869 end do
1870 end do
1871 else !< bc_z%end
1872 do i = 1, num_dims + 1
1873 do j = 1, buff_size
1874 c_divs(i)%sf(k, l, p + j) = c_divs(i)%sf(k, l, p)
1875 end do
1876 end do
1877 end if
1878 end if
1879
1880 end subroutine s_color_function_ghost_cell_extrapolation
1881
1882 !> Apply periodic boundary conditions to the IGR Jacobian field by copying values from the opposite domain boundary.
1883 subroutine s_f_igr_periodic(jac_sf, bc_dir, bc_loc, k, l)
1884
1885
1886# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1887#ifdef _CRAYFTN
1888# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1889#if MFC_OpenACC
1890# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1891!$acc routine seq
1892# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1893#elif MFC_OpenMP
1894# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1895
1896# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1897
1898# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1899!$omp declare target device_type(any)
1900# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1901#else
1902# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1903!DIR$ INLINEALWAYS s_F_igr_periodic
1904# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1905#endif
1906# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1907#elif MFC_OpenACC
1908# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1909!$acc routine seq
1910# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1911#elif MFC_OpenMP
1912# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1913
1914# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1915
1916# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1917!$omp declare target device_type(any)
1918# 1256 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1919#endif
1920 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
1921 integer, intent(in) :: bc_dir, bc_loc
1922 integer, intent(in) :: k, l
1923 integer :: j
1924
1925 if (bc_dir == 1) then
1926 if (bc_loc == -1) then
1927 do j = 1, buff_size
1928 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(m - j + 1, k, l)
1929 end do
1930 else
1931 do j = 1, buff_size
1932 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(j - 1, k, l)
1933 end do
1934 end if
1935 else if (bc_dir == 2) then
1936 if (bc_loc == -1) then
1937 do j = 1, buff_size
1938 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, n - j + 1, l)
1939 end do
1940 else
1941 do j = 1, buff_size
1942 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, j - 1, l)
1943 end do
1944 end if
1945 else
1946 if (bc_loc == -1) then
1947 do j = 1, buff_size
1948 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, p - j + 1)
1949 end do
1950 else
1951 do j = 1, buff_size
1952 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, j - 1)
1953 end do
1954 end if
1955 end if
1956
1957 end subroutine s_f_igr_periodic
1958
1959 !> Apply reflective boundary conditions to the IGR Jacobian field by mirroring values across the boundary.
1960 subroutine s_f_igr_reflective(jac_sf, bc_dir, bc_loc, k, l)
1961
1962
1963# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1964#ifdef _CRAYFTN
1965# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1966#if MFC_OpenACC
1967# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1968!$acc routine seq
1969# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1970#elif MFC_OpenMP
1971# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1972
1973# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1974
1975# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1976!$omp declare target device_type(any)
1977# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1978#else
1979# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1980!DIR$ INLINEALWAYS s_F_igr_reflective
1981# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1982#endif
1983# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1984#elif MFC_OpenACC
1985# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1986!$acc routine seq
1987# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1988#elif MFC_OpenMP
1989# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1990
1991# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1992
1993# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1994!$omp declare target device_type(any)
1995# 1299 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
1996#endif
1997 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
1998 integer, intent(in) :: bc_dir, bc_loc
1999 integer, intent(in) :: k, l
2000 integer :: j
2001
2002 if (bc_dir == 1) then
2003 if (bc_loc == -1) then
2004 do j = 1, buff_size
2005 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(j - 1, k, l)
2006 end do
2007 else
2008 do j = 1, buff_size
2009 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(m - (j - 1), k, l)
2010 end do
2011 end if
2012 else if (bc_dir == 2) then
2013 if (bc_loc == -1) then
2014 do j = 1, buff_size
2015 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, j - 1, l)
2016 end do
2017 else
2018 do j = 1, buff_size
2019 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, n - (j - 1), l)
2020 end do
2021 end if
2022 else
2023 if (bc_loc == -1) then
2024 do j = 1, buff_size
2025 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, j - 1)
2026 end do
2027 else
2028 do j = 1, buff_size
2029 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, p - (j - 1))
2030 end do
2031 end if
2032 end if
2033
2034 end subroutine s_f_igr_reflective
2035
2036 !> Extrapolate the IGR Jacobian field into ghost cells by copying boundary values.
2037 subroutine s_f_igr_ghost_cell_extrapolation(jac_sf, bc_dir, bc_loc, k, l)
2038
2039
2040# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2041#ifdef _CRAYFTN
2042# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2043#if MFC_OpenACC
2044# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2045!$acc routine seq
2046# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2047#elif MFC_OpenMP
2048# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2049
2050# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2051
2052# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2053!$omp declare target device_type(any)
2054# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2055#else
2056# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2057!DIR$ INLINEALWAYS s_F_igr_ghost_cell_extrapolation
2058# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2059#endif
2060# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2061#elif MFC_OpenACC
2062# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2063!$acc routine seq
2064# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2065#elif MFC_OpenMP
2066# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2067
2068# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2069
2070# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2071!$omp declare target device_type(any)
2072# 1342 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2073#endif
2074 type(scalar_field), dimension(1:), intent(inout) :: jac_sf
2075 integer, intent(in) :: bc_dir, bc_loc
2076 integer, intent(in) :: k, l
2077 integer :: j
2078
2079 if (bc_dir == 1) then
2080 if (bc_loc == -1) then
2081 do j = 1, buff_size
2082 jac_sf(1)%sf(-j, k, l) = jac_sf(1)%sf(0, k, l)
2083 end do
2084 else
2085 do j = 1, buff_size
2086 jac_sf(1)%sf(m + j, k, l) = jac_sf(1)%sf(m, k, l)
2087 end do
2088 end if
2089 else if (bc_dir == 2) then
2090 if (bc_loc == -1) then
2091 do j = 1, buff_size
2092 jac_sf(1)%sf(k, -j, l) = jac_sf(1)%sf(k, 0, l)
2093 end do
2094 else
2095 do j = 1, buff_size
2096 jac_sf(1)%sf(k, n + j, l) = jac_sf(1)%sf(k, n, l)
2097 end do
2098 end if
2099 else
2100 if (bc_loc == -1) then
2101 do j = 1, buff_size
2102 jac_sf(1)%sf(k, l, -j) = jac_sf(1)%sf(k, l, 0)
2103 end do
2104 else
2105 do j = 1, buff_size
2106 jac_sf(1)%sf(k, l, p + j) = jac_sf(1)%sf(k, l, p)
2107 end do
2108 end if
2109 end if
2110
2111 end subroutine s_f_igr_ghost_cell_extrapolation
2112
2113 subroutine s_beta_periodic(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
2114
2115
2116# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2117#ifdef _CRAYFTN
2118# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2119#if MFC_OpenACC
2120# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2121!$acc routine seq
2122# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2123#elif MFC_OpenMP
2124# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2125
2126# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2127
2128# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2129!$omp declare target device_type(any)
2130# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2131#else
2132# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2133!DIR$ INLINEALWAYS s_beta_periodic
2134# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2135#endif
2136# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2137#elif MFC_OpenACC
2138# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2139!$acc routine seq
2140# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2141#elif MFC_OpenMP
2142# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2143
2144# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2145
2146# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2147!$omp declare target device_type(any)
2148# 1384 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2149#endif
2150 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2151 type(scalar_field), dimension(num_dims + 1), intent(inout) :: kahan_comp
2152 integer, intent(in) :: bc_dir, bc_loc
2153 integer, intent(in) :: k, l
2154 integer, intent(in) :: nvar
2155 integer :: j, i
2156 real(wp) :: y_kahan, t_kahan
2157
2158 if (bc_dir == 1) then !< x-direction
2159 if (bc_loc == -1) then ! bc%x%beg
2160 do i = 1, nvar
2161 do j = -mapcells - 1, mapcells
2162 ! Kahan-compensated addition of ghost to interior
2163 y_kahan = real(q_beta(beta_vars(i))%sf(m + j + 1, k, l), &
2164 & kind=wp) + kahan_comp(beta_vars(i))%sf(m + j + 1, k, l) - kahan_comp(beta_vars(i))%sf(j, &
2165 & k, l)
2166 t_kahan = real(q_beta(beta_vars(i))%sf(j, k, l), kind=wp) + y_kahan
2167 kahan_comp(beta_vars(i))%sf(j, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j, k, l)) - y_kahan
2168 q_beta(beta_vars(i))%sf(j, k, l) = t_kahan
2169 end do
2170 end do
2171 else
2172 do i = 1, nvar
2173 do j = -mapcells, mapcells + 1
2174 q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l)
2175 kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2176 end do
2177 end do
2178 end if
2179 else if (bc_dir == 2) then !< y-direction
2180 if (bc_loc == -1) then !< bc%y%beg
2181 do i = 1, nvar
2182 do j = -mapcells - 1, mapcells
2183 y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j + 1, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, &
2184 & n + j + 1, l) - kahan_comp(beta_vars(i))%sf(k, j, l)
2185 t_kahan = real(q_beta(beta_vars(i))%sf(k, j, l), kind=wp) + y_kahan
2186 kahan_comp(beta_vars(i))%sf(k, j, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j, l)) - y_kahan
2187 q_beta(beta_vars(i))%sf(k, j, l) = t_kahan
2188 end do
2189 end do
2190 else
2191 do i = 1, nvar
2192 do j = -mapcells, mapcells + 1
2193 q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l)
2194 kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2195 end do
2196 end do
2197 end if
2198 else if (bc_dir == 3) then !< z-direction
2199 if (bc_loc == -1) then !< bc%z%beg
2200 do i = 1, nvar
2201 do j = -mapcells - 1, mapcells
2202 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j + 1), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2203 & p + j + 1) - kahan_comp(beta_vars(i))%sf(k, l, j)
2204 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j), kind=wp) + y_kahan
2205 kahan_comp(beta_vars(i))%sf(k, l, j) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j)) - y_kahan
2206 q_beta(beta_vars(i))%sf(k, l, j) = t_kahan
2207 end do
2208 end do
2209 else
2210 do i = 1, nvar
2211 do j = -mapcells, mapcells + 1
2212 q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, j - 1)
2213 kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2214 end do
2215 end do
2216 end if
2217 end if
2218
2219 end subroutine s_beta_periodic
2220
2221 subroutine s_beta_extrapolation(q_beta, bc_dir, bc_loc, k, l, nvar)
2222
2223
2224# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2225#ifdef _CRAYFTN
2226# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2227#if MFC_OpenACC
2228# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2229!$acc routine seq
2230# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2231#elif MFC_OpenMP
2232# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2233
2234# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2235
2236# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2237!$omp declare target device_type(any)
2238# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2239#else
2240# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2241!DIR$ INLINEALWAYS s_beta_extrapolation
2242# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2243#endif
2244# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2245#elif MFC_OpenACC
2246# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2247!$acc routine seq
2248# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2249#elif MFC_OpenMP
2250# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2251
2252# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2253
2254# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2255!$omp declare target device_type(any)
2256# 1458 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2257#endif
2258 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2259 integer, intent(in) :: bc_dir, bc_loc
2260 integer, intent(in) :: k, l
2261 integer, intent(in) :: nvar
2262 integer :: j, i
2263
2264 if (bc_dir == 1) then !< x-direction
2265 if (bc_loc == -1) then ! bc%x%beg
2266 do i = 1, nvar
2267 do j = 1, buff_size
2268 q_beta(beta_vars(i))%sf(-j, k, l) = 0._wp
2269 end do
2270 end do
2271 else
2272 do i = 1, nvar
2273 do j = 1, buff_size
2274 q_beta(beta_vars(i))%sf(m + j, k, l) = 0._wp
2275 end do
2276 end do
2277 end if
2278 else if (bc_dir == 2) then !< y-direction
2279 if (bc_loc == -1) then !< bc%y%beg
2280 do i = 1, nvar
2281 do j = 1, buff_size
2282 q_beta(beta_vars(i))%sf(k, -j, l) = 0._wp
2283 end do
2284 end do
2285 else
2286 do i = 1, nvar
2287 do j = 1, buff_size
2288 q_beta(beta_vars(i))%sf(k, n + j, l) = 0._wp
2289 end do
2290 end do
2291 end if
2292 else if (bc_dir == 3) then !< z-direction
2293 if (bc_loc == -1) then !< bc%z%beg
2294 do i = 1, nvar
2295 do j = 1, buff_size
2296 q_beta(beta_vars(i))%sf(k, l, -j) = 0._wp
2297 end do
2298 end do
2299 else !< bc%z%end
2300 do i = 1, nvar
2301 do j = 1, buff_size
2302 q_beta(beta_vars(i))%sf(k, l, p + j) = 0._wp
2303 end do
2304 end do
2305 end if
2306 end if
2307
2308 end subroutine s_beta_extrapolation
2309
2310 subroutine s_beta_reflective(q_beta, kahan_comp, bc_dir, bc_loc, k, l, nvar)
2311
2312
2313# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2314#ifdef _CRAYFTN
2315# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2316#if MFC_OpenACC
2317# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2318!$acc routine seq
2319# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2320#elif MFC_OpenMP
2321# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2322
2323# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2324
2325# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2326!$omp declare target device_type(any)
2327# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2328#else
2329# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2330!DIR$ INLINEALWAYS s_beta_reflective
2331# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2332#endif
2333# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2334#elif MFC_OpenACC
2335# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2336!$acc routine seq
2337# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2338#elif MFC_OpenMP
2339# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2340
2341# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2342
2343# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2344!$omp declare target device_type(any)
2345# 1513 "/home/runner/work/MFC/MFC/src/common/m_boundary_primitives.fpp"
2346#endif
2347 type(scalar_field), dimension(num_dims + 1), intent(inout) :: q_beta
2348 type(scalar_field), dimension(num_dims + 1), intent(inout) :: kahan_comp
2349 integer, intent(in) :: bc_dir, bc_loc
2350 integer, intent(in) :: k, l
2351 integer, intent(in) :: nvar
2352 integer :: j, i
2353 real(wp) :: y_kahan, t_kahan
2354
2355 ! Reflective BC for void fraction: 1) Fold ghost-cell contributions back onto their mirror interior cells (Kahan) 2) Set
2356 ! ghost cells = mirror of (now-folded) interior values
2357
2358 if (bc_dir == 1) then !< x-direction
2359 if (bc_loc == -1) then ! bc%x%beg
2360 do i = 1, nvar
2361 do j = 1, mapcells + 1
2362 y_kahan = real(q_beta(beta_vars(i))%sf(-j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(-j, k, &
2363 & l) - kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2364 t_kahan = real(q_beta(beta_vars(i))%sf(j - 1, k, l), kind=wp) + y_kahan
2365 kahan_comp(beta_vars(i))%sf(j - 1, k, l) = (t_kahan - q_beta(beta_vars(i))%sf(j - 1, k, l)) - y_kahan
2366 q_beta(beta_vars(i))%sf(j - 1, k, l) = t_kahan
2367 end do
2368 do j = 1, mapcells + 1
2369 q_beta(beta_vars(i))%sf(-j, k, l) = q_beta(beta_vars(i))%sf(j - 1, k, l)
2370 kahan_comp(beta_vars(i))%sf(-j, k, l) = kahan_comp(beta_vars(i))%sf(j - 1, k, l)
2371 end do
2372 end do
2373 else !< bc%x%end
2374 do i = 1, nvar
2375 do j = 1, mapcells + 1
2376 y_kahan = real(q_beta(beta_vars(i))%sf(m + j, k, l), kind=wp) + kahan_comp(beta_vars(i))%sf(m + j, k, &
2377 & l) - kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l)
2378 t_kahan = real(q_beta(beta_vars(i))%sf(m - (j - 1), k, l), kind=wp) + y_kahan
2379 kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l) = (t_kahan - q_beta(beta_vars(i))%sf(m - (j - 1), k, &
2380 & l)) - y_kahan
2381 q_beta(beta_vars(i))%sf(m - (j - 1), k, l) = t_kahan
2382 end do
2383 do j = 1, mapcells + 1
2384 q_beta(beta_vars(i))%sf(m + j, k, l) = q_beta(beta_vars(i))%sf(m - (j - 1), k, l)
2385 kahan_comp(beta_vars(i))%sf(m + j, k, l) = kahan_comp(beta_vars(i))%sf(m - (j - 1), k, l)
2386 end do
2387 end do
2388 end if
2389 else if (bc_dir == 2) then !< y-direction
2390 if (bc_loc == -1) then !< bc%y%beg
2391 do i = 1, nvar
2392 do j = 1, mapcells + 1
2393 y_kahan = real(q_beta(beta_vars(i))%sf(k, -j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, -j, &
2394 & l) - kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2395 t_kahan = real(q_beta(beta_vars(i))%sf(k, j - 1, l), kind=wp) + y_kahan
2396 kahan_comp(beta_vars(i))%sf(k, j - 1, l) = (t_kahan - q_beta(beta_vars(i))%sf(k, j - 1, l)) - y_kahan
2397 q_beta(beta_vars(i))%sf(k, j - 1, l) = t_kahan
2398 end do
2399 do j = 1, mapcells + 1
2400 q_beta(beta_vars(i))%sf(k, -j, l) = q_beta(beta_vars(i))%sf(k, j - 1, l)
2401 kahan_comp(beta_vars(i))%sf(k, -j, l) = kahan_comp(beta_vars(i))%sf(k, j - 1, l)
2402 end do
2403 end do
2404 else !< bc%y%end
2405 do i = 1, nvar
2406 do j = 1, mapcells + 1
2407 y_kahan = real(q_beta(beta_vars(i))%sf(k, n + j, l), kind=wp) + kahan_comp(beta_vars(i))%sf(k, n + j, &
2408 & l) - kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l)
2409 t_kahan = real(q_beta(beta_vars(i))%sf(k, n - (j - 1), l), kind=wp) + y_kahan
2410 kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l) = (t_kahan - q_beta(beta_vars(i))%sf(k, n - (j - 1), &
2411 & l)) - y_kahan
2412 q_beta(beta_vars(i))%sf(k, n - (j - 1), l) = t_kahan
2413 end do
2414 do j = 1, mapcells + 1
2415 q_beta(beta_vars(i))%sf(k, n + j, l) = q_beta(beta_vars(i))%sf(k, n - (j - 1), l)
2416 kahan_comp(beta_vars(i))%sf(k, n + j, l) = kahan_comp(beta_vars(i))%sf(k, n - (j - 1), l)
2417 end do
2418 end do
2419 end if
2420 else if (bc_dir == 3) then !< z-direction
2421 if (bc_loc == -1) then !< bc%z%beg
2422 do i = 1, nvar
2423 do j = 1, mapcells + 1
2424 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, -j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2425 & -j) - kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2426 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, j - 1), kind=wp) + y_kahan
2427 kahan_comp(beta_vars(i))%sf(k, l, j - 1) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, j - 1)) - y_kahan
2428 q_beta(beta_vars(i))%sf(k, l, j - 1) = t_kahan
2429 end do
2430 do j = 1, mapcells + 1
2431 q_beta(beta_vars(i))%sf(k, l, -j) = q_beta(beta_vars(i))%sf(k, l, j - 1)
2432 kahan_comp(beta_vars(i))%sf(k, l, -j) = kahan_comp(beta_vars(i))%sf(k, l, j - 1)
2433 end do
2434 end do
2435 else !< bc%z%end
2436 do i = 1, nvar
2437 do j = 1, mapcells + 1
2438 y_kahan = real(q_beta(beta_vars(i))%sf(k, l, p + j), kind=wp) + kahan_comp(beta_vars(i))%sf(k, l, &
2439 & p + j) - kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1))
2440 t_kahan = real(q_beta(beta_vars(i))%sf(k, l, p - (j - 1)), kind=wp) + y_kahan
2441 kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1)) = (t_kahan - q_beta(beta_vars(i))%sf(k, l, &
2442 & p - (j - 1))) - y_kahan
2443 q_beta(beta_vars(i))%sf(k, l, p - (j - 1)) = t_kahan
2444 end do
2445 do j = 1, mapcells + 1
2446 q_beta(beta_vars(i))%sf(k, l, p + j) = q_beta(beta_vars(i))%sf(k, l, p - (j - 1))
2447 kahan_comp(beta_vars(i))%sf(k, l, p + j) = kahan_comp(beta_vars(i))%sf(k, l, p - (j - 1))
2448 end do
2449 end do
2450 end if
2451 end if
2452
2453 end subroutine s_beta_reflective
2454
2455#ifndef MFC_PRE_PROCESS
2456 !> Apply periodic boundary conditions to grid variables by copying cell widths from opposite domain boundary.
2457 subroutine s_grid_periodic_bc(bc_dir, bc_loc, offset_dir)
2458
2459 integer, intent(in) :: bc_dir, bc_loc
2460 type(int_bounds_info), intent(in) :: offset_dir
2461 integer :: i
2462
2463 if (bc_dir == 1) then
2464 if (bc_loc == -1) then
2465 do i = 1, buff_size
2466 dx(-i) = dx(m - (i - 1))
2467 end do
2468 do i = 1, offset_dir%beg
2469 x_cb(-1 - i) = x_cb(-i) - dx(-i)
2470 end do
2471 do i = 1, buff_size
2472 x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2._wp
2473 end do
2474 else
2475 do i = 1, buff_size
2476 dx(m + i) = dx(i - 1)
2477 end do
2478 do i = 1, offset_dir%end
2479 x_cb(m + i) = x_cb(m + (i - 1)) + dx(m + i)
2480 end do
2481 do i = 1, buff_size
2482 x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2._wp
2483 end do
2484 end if
2485 else if (bc_dir == 2) then
2486 if (bc_loc == -1) then
2487 do i = 1, buff_size
2488 dy(-i) = dy(n - (i - 1))
2489 end do
2490 do i = 1, offset_dir%beg
2491 y_cb(-1 - i) = y_cb(-i) - dy(-i)
2492 end do
2493 do i = 1, buff_size
2494 y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp
2495 end do
2496 else
2497 do i = 1, buff_size
2498 dy(n + i) = dy(i - 1)
2499 end do
2500 do i = 1, offset_dir%end
2501 y_cb(n + i) = y_cb(n + (i - 1)) + dy(n + i)
2502 end do
2503 do i = 1, buff_size
2504 y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2._wp
2505 end do
2506 end if
2507 else
2508 if (bc_loc == -1) then
2509 do i = 1, buff_size
2510 dz(-i) = dz(p - (i - 1))
2511 end do
2512 do i = 1, offset_dir%beg
2513 z_cb(-1 - i) = z_cb(-i) - dz(-i)
2514 end do
2515 do i = 1, buff_size
2516 z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2._wp
2517 end do
2518 else
2519 do i = 1, buff_size
2520 dz(p + i) = dz(i - 1)
2521 end do
2522 do i = 1, offset_dir%end
2523 z_cb(p + i) = z_cb(p + (i - 1)) + dz(p + i)
2524 end do
2525 do i = 1, buff_size
2526 z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp
2527 end do
2528 end if
2529 end if
2530
2531 end subroutine s_grid_periodic_bc
2532
2533 !> Apply reflective boundary conditions to grid variables by mirroring cell widths across the boundary.
2534 subroutine s_grid_reflective_bc(bc_dir, bc_loc, offset_dir)
2535
2536 integer, intent(in) :: bc_dir, bc_loc
2537 type(int_bounds_info), intent(in) :: offset_dir
2538 integer :: i
2539
2540 if (bc_dir == 1) then
2541 if (bc_loc == -1) then
2542 do i = 1, buff_size
2543 dx(-i) = dx(i - 1)
2544 end do
2545 do i = 1, offset_dir%beg
2546 x_cb(-1 - i) = x_cb(-i) - dx(-i)
2547 end do
2548 do i = 1, buff_size
2549 x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2._wp
2550 end do
2551 else
2552 do i = 1, buff_size
2553 dx(m + i) = dx(m - (i - 1))
2554 end do
2555 do i = 1, offset_dir%end
2556 x_cb(m + i) = x_cb(m + (i - 1)) + dx(m + i)
2557 end do
2558 do i = 1, buff_size
2559 x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2._wp
2560 end do
2561 end if
2562 else if (bc_dir == 2) then
2563 if (bc_loc == -1) then
2564 do i = 1, buff_size
2565 dy(-i) = dy(i - 1)
2566 end do
2567 do i = 1, offset_dir%beg
2568 y_cb(-1 - i) = y_cb(-i) - dy(-i)
2569 end do
2570 do i = 1, buff_size
2571 y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp
2572 end do
2573 else
2574 do i = 1, buff_size
2575 dy(n + i) = dy(n - (i - 1))
2576 end do
2577 do i = 1, offset_dir%end
2578 y_cb(n + i) = y_cb(n + (i - 1)) + dy(n + i)
2579 end do
2580 do i = 1, buff_size
2581 y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2._wp
2582 end do
2583 end if
2584 else
2585 if (bc_loc == -1) then
2586 do i = 1, buff_size
2587 dz(-i) = dz(i - 1)
2588 end do
2589 do i = 1, offset_dir%beg
2590 z_cb(-1 - i) = z_cb(-i) - dz(-i)
2591 end do
2592 do i = 1, buff_size
2593 z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2._wp
2594 end do
2595 else
2596 do i = 1, buff_size
2597 dz(p + i) = dz(p - (i - 1))
2598 end do
2599 do i = 1, offset_dir%end
2600 z_cb(p + i) = z_cb(p + (i - 1)) + dz(p + i)
2601 end do
2602 do i = 1, buff_size
2603 z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp
2604 end do
2605 end if
2606 end if
2607
2608 end subroutine s_grid_reflective_bc
2609
2610 !> Extrapolate grid variables by copying boundary cell width into ghost cells.
2611 subroutine s_grid_ghost_cell_extrapolation_bc(bc_dir, bc_loc, offset_dir)
2612
2613 integer, intent(in) :: bc_dir, bc_loc
2614 type(int_bounds_info), intent(in) :: offset_dir
2615 integer :: i
2616
2617 if (bc_dir == 1) then
2618 if (bc_loc == -1) then
2619 do i = 1, buff_size
2620 dx(-i) = dx(0)
2621 end do
2622 do i = 1, offset_dir%beg
2623 x_cb(-1 - i) = x_cb(-i) - dx(-i)
2624 end do
2625 do i = 1, buff_size
2626 x_cc(-i) = x_cc(1 - i) - (dx(1 - i) + dx(-i))/2._wp
2627 end do
2628 else
2629 do i = 1, buff_size
2630 dx(m + i) = dx(m)
2631 end do
2632 do i = 1, offset_dir%end
2633 x_cb(m + i) = x_cb(m + (i - 1)) + dx(m + i)
2634 end do
2635 do i = 1, buff_size
2636 x_cc(m + i) = x_cc(m + (i - 1)) + (dx(m + (i - 1)) + dx(m + i))/2._wp
2637 end do
2638 end if
2639 else if (bc_dir == 2) then
2640 if (bc_loc == -1) then
2641 do i = 1, buff_size
2642 dy(-i) = dy(0)
2643 end do
2644 do i = 1, offset_dir%beg
2645 y_cb(-1 - i) = y_cb(-i) - dy(-i)
2646 end do
2647 do i = 1, buff_size
2648 y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp
2649 end do
2650 else
2651 do i = 1, buff_size
2652 dy(n + i) = dy(n)
2653 end do
2654 do i = 1, offset_dir%end
2655 y_cb(n + i) = y_cb(n + (i - 1)) + dy(n + i)
2656 end do
2657 do i = 1, buff_size
2658 y_cc(n + i) = y_cc(n + (i - 1)) + (dy(n + (i - 1)) + dy(n + i))/2._wp
2659 end do
2660 end if
2661 else
2662 if (bc_loc == -1) then
2663 do i = 1, buff_size
2664 dz(-i) = dz(0)
2665 end do
2666 do i = 1, offset_dir%beg
2667 z_cb(-1 - i) = z_cb(-i) - dz(-i)
2668 end do
2669 do i = 1, buff_size
2670 z_cc(-i) = z_cc(1 - i) - (dz(1 - i) + dz(-i))/2._wp
2671 end do
2672 else
2673 do i = 1, buff_size
2674 dz(p + i) = dz(p)
2675 end do
2676 do i = 1, offset_dir%end
2677 z_cb(p + i) = z_cb(p + (i - 1)) + dz(p + i)
2678 end do
2679 do i = 1, buff_size
2680 z_cc(p + i) = z_cc(p + (i - 1)) + (dz(p + (i - 1)) + dz(p + i))/2._wp
2681 end do
2682 end if
2683 end if
2684
2685 end subroutine s_grid_ghost_cell_extrapolation_bc
2686
2687 !> Apply axis boundary conditions to grid variables for cylindrical coordinates.
2688 subroutine s_grid_axis_bc(bc_loc, offset_dir)
2689
2690 integer, intent(in) :: bc_loc
2691 type(int_bounds_info), intent(in) :: offset_dir
2692 integer :: i
2693
2694 if (bc_loc == -1) then
2695 do i = 1, buff_size
2696 dy(-i) = dy(i - 1)
2697 end do
2698 do i = 1, offset_dir%beg
2699 y_cb(-1 - i) = y_cb(-i) - dy(-i)
2700 end do
2701 do i = 1, buff_size
2702 y_cc(-i) = y_cc(1 - i) - (dy(1 - i) + dy(-i))/2._wp
2703 end do
2704 end if
2705
2706 end subroutine s_grid_axis_bc
2707#endif
2708end 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:985
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:2114
m_boundary_primitives::s_grid_axis_bc
subroutine s_grid_axis_bc(bc_loc, offset_dir)
Apply axis boundary conditions to grid variables for cylindrical coordinates.
Definition m_boundary_primitives.fpp.f90:2689
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:1884
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:1593
m_boundary_primitives::bc_buffers
type(scalar_field), dimension(:,:), allocatable bc_buffers
Definition m_boundary_primitives.fpp.f90:343
m_boundary_primitives::s_grid_ghost_cell_extrapolation_bc
subroutine s_grid_ghost_cell_extrapolation_bc(bc_dir, bc_loc, offset_dir)
Extrapolate grid variables by copying boundary cell width into ghost cells.
Definition m_boundary_primitives.fpp.f90:2612
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:2038
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:1171
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:916
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:1506
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:1682
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:2311
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:2222
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:1961
m_boundary_primitives::s_grid_reflective_bc
subroutine s_grid_reflective_bc(bc_dir, bc_loc, offset_dir)
Apply reflective boundary conditions to grid variables by mirroring cell widths across the boundary.
Definition m_boundary_primitives.fpp.f90:2535
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:743
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:360
m_boundary_primitives::s_grid_periodic_bc
subroutine s_grid_periodic_bc(bc_dir, bc_loc, offset_dir)
Apply periodic boundary conditions to grid variables by copying cell widths from opposite domain boun...
Definition m_boundary_primitives.fpp.f90:2458
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:1795
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:481
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:1378
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::y_cc
real(wp), dimension(:), allocatable y_cc
Definition m_global_parameters.fpp.f90:69
m_global_parameters::y_cb
real(wp), dimension(:), allocatable y_cb
Definition m_global_parameters.fpp.f90:64
m_global_parameters::dz
real(wp), dimension(:), allocatable dz
Definition m_global_parameters.fpp.f90:75
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::z_cb
real(wp), dimension(:), allocatable z_cb
Definition m_global_parameters.fpp.f90:64
m_global_parameters::bc_y
type(int_bounds_info) bc_y
Definition m_global_parameters.fpp.f90:106
m_global_parameters::x_cc
real(wp), dimension(:), allocatable x_cc
Definition m_global_parameters.fpp.f90:69
m_global_parameters::bc_x
type(int_bounds_info) bc_x
Definition m_global_parameters.fpp.f90:106
m_global_parameters::x_cb
real(wp), dimension(:), allocatable x_cb
Definition m_global_parameters.fpp.f90:64
m_global_parameters::dy
real(wp), dimension(:), allocatable dy
Definition m_global_parameters.fpp.f90:75
m_global_parameters::z_cc
real(wp), dimension(:), allocatable z_cc
Definition m_global_parameters.fpp.f90:69
m_global_parameters::dx
real(wp), dimension(:), allocatable dx
Cell-width distributions in the x-, y- and z-coordinate directions.
Definition m_global_parameters.fpp.f90:75
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:368
m_derived_types::int_bounds_info
Integer bounds for variables.
Definition m_derived_types.fpp.f90:417
m_derived_types::scalar_field
Derived type annexing a scalar field (SF).
Definition m_derived_types.fpp.f90:337