MFC
Exascale flow solver
Loading...
Searching...
No Matches
m_riemann_solver_hypo_hlld.fpp.f90
Go to the documentation of this file.
1# 1 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2!>
3!! @file
4!! @brief Contains module m_riemann_solver_hypo_hlld
5
6!> @brief Dual-pass HLLD approximate Riemann solver for hypoelastic flows, with non-conservative interface-velocity coupling
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/simulation/m_riemann_solver_hypo_hlld.fpp" 2
18# 1 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 1
19# 1 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 1
20# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
21# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
22# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
23# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
24# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
25# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
26
27# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
28# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
29# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
30
31# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
32
33# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
34
35# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
36
37# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
38
39# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
40
41# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
42
43# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
44
45# 167 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
46! New line at end of file is required for FYPP
47# 2 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
48# 1 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 1
49# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
50# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
51# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
52# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
53# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
54# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
55
56# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
57# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
58# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
59
60# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
61
62# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
63
64# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
65
66# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
67
68# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
69
70# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
71
72# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
73
74# 167 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
75! New line at end of file is required for FYPP
76# 2 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp" 2
77
78# 4 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
79# 5 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
80# 6 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
81# 7 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
82# 8 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
83
84# 20 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
85
86# 43 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
87
88# 48 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
89
90# 53 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
91
92# 58 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
93
94# 63 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
95
96# 68 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
97
98# 76 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
99
100# 81 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
101
102# 86 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
103
104# 91 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
105
106# 96 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
107
108# 101 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
109
110# 106 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
111
112# 111 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
113
114# 116 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
115
116# 121 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
117
118# 151 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
119
120# 192 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
121
122# 206 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
123
124# 231 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
125
126# 242 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
127
128# 244 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
129# 255 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
130
131# 284 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
132
133# 294 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
134
135# 304 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
136
137# 313 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
138
139# 330 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
140
141# 340 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
142
143# 347 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
144
145# 353 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
146
147# 359 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
148
149# 365 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
150
151# 371 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
152
153# 377 "/home/runner/work/MFC/MFC/src/common/include/omp_macros.fpp"
154! New line at end of file is required for FYPP
155# 3 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
156# 1 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 1
157# 1 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp" 1
158# 2 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
159# 3 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
160# 4 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
161# 5 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
162# 6 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
163
164# 8 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
165# 9 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
166# 10 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
167
168# 17 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
169
170# 46 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
171
172# 58 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
173
174# 68 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
175
176# 98 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
177
178# 110 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
179
180# 120 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
181
182# 167 "/home/runner/work/MFC/MFC/src/common/include/shared_parallel_macros.fpp"
183! New line at end of file is required for FYPP
184# 2 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp" 2
185
186# 7 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
187
188# 17 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
189
190# 22 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
191
192# 27 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
193
194# 32 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
195
196# 37 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
197
198# 42 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
199
200# 47 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
201
202# 52 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
203
204# 57 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
205
206# 62 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
207
208# 73 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
209
210# 78 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
211
212# 83 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
213
214# 88 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
215
216# 103 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
217
218# 131 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
219
220# 160 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
221
222# 175 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
223
224# 193 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
225
226# 215 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
227
228# 244 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
229
230# 259 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
231
232# 269 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
233
234# 278 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
235
236# 294 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
237
238# 304 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
239
240# 311 "/home/runner/work/MFC/MFC/src/common/include/acc_macros.fpp"
241! New line at end of file is required for FYPP
242# 4 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp" 2
243
244! GPU parallel region (scalar reductions, maxval/minval)
245# 23 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
246
247! GPU parallel loop over threads (most common GPU macro)
248# 43 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
249
250! Required closing for GPU_PARALLEL_LOOP
251# 55 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
252
253! Mark routine for device compilation
254# 112 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
255
256! Declare device-resident data
257# 130 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
258
259! Inner loop within a GPU parallel region
260# 145 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
261
262! Scoped GPU data region
263# 164 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
264
265! Host code with device pointers (for MPI with GPU buffers)
266# 193 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
267
268! Allocate device memory (unscoped)
269# 207 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
270
271! Free device memory
272# 219 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
273
274! Atomic operation on device
275# 231 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
276
277! End atomic capture block
278# 242 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
279
280! Copy data between host and device
281# 254 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
282
283! Synchronization barrier
284# 266 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
285
286! Import GPU library module (openacc or omp_lib)
287# 275 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
288
289! Emit code only for AMD compiler
290# 282 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
291
292! Emit code for non-Cray compilers
293# 289 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
294
295! Emit code only for Cray compiler
296# 296 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
297
298! Emit code for non-NVIDIA compilers
299# 303 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
300
301# 305 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
302# 306 "/home/runner/work/MFC/MFC/src/common/include/parallel_macros.fpp"
303! New line at end of file is required for FYPP
304# 2 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp" 2
305
306# 14 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
307
308! Caution: This macro requires the use of a binding script to set CUDA_VISIBLE_DEVICES, such that we have one GPU device per MPI
309! rank. That's because for both cudaMemAdvise (preferred location) and cudaMemPrefetchAsync we use location = device_id = 0. For an
310! example see misc/nvidia_uvm/bind.sh.
311# 55 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
312
313! Allocate and create GPU device memory
314# 75 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
315
316! Free GPU device memory and deallocate
317# 83 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
318
319! Cray-specific GPU pointer setup for vector fields
320# 107 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
321
322! Cray-specific GPU pointer setup for scalar fields
323# 123 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
324
325! Cray-specific GPU pointer setup for acoustic source spatials
326# 148 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
327
328# 154 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
329
330# 161 "/home/runner/work/MFC/MFC/src/common/include/macros.fpp"
331! New line at end of file is required for FYPP
332# 8 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp" 2
333# 1 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp" 1
334# 13 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
335
336# 60 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
337
338# 70 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
339
340# 94 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
341
342# 109 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
343
344# 116 "/home/runner/work/MFC/MFC/src/simulation/include/inline_riemann.fpp"
345# 9 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp" 2
346
347! Single source of truth for the per-component HLL flux on the (U_L, U_R, F_L, F_R) compact
348! basis: used by the degenerate-fan fallback and the ADC blend, which must stay consistent.
349! Textual inlining; codegen is identical to the materialized expression.
350# 16 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
351
352module m_riemann_solver_hypo_hlld
353
354 use m_derived_types
355 use m_global_parameters
356 use m_variables_conversion
357 use m_riemann_state
358
359 implicit none
360
361 !> Four-epsilon roundoff band for G_eff: two mixture products, their sum, and the final signed sum. Relative to the operand
362 !! scale; not a physical stiffness cutoff.
363 real(wp), parameter :: g_eff_roundoff_factor = 4._wp
364
365contains
366
367 !> Classify the position of the interface (xi = 0) in the five-wave HLLD fan: 0 left of S_L, 1..4 for the four inner wedges, 5
368 !! right of S_R. Single definition of the wave-fan geometry shared by the flux fold, the NC face-velocity export, and the
369 !! axisymmetric face-state pick, which must stay consistent. Valid fans only: a fallback face exports the HLL/one-sided traces
370 !! instead of a fan classification.
371 integer function f_hlld_wave_zone(S_L, S_Lstar, s_M, S_Rstar, S_R) result(zone)
372
373
374# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
375#ifdef _CRAYFTN
376# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
377#if MFC_OpenACC
378# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
379!$acc routine seq
380# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
381#elif MFC_OpenMP
382# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
383
384# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
385
386# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
387!$omp declare target device_type(any)
388# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
389#else
390# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
391!DIR$ INLINEALWAYS f_hlld_wave_zone
392# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
393#endif
394# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
395#elif MFC_OpenACC
396# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
397!$acc routine seq
398# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
399#elif MFC_OpenMP
400# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
401
402# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
403
404# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
405!$omp declare target device_type(any)
406# 38 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
407#endif
408 real(wp), intent(in) :: s_l, s_lstar, s_m, s_rstar, s_r
409
410 if (0._wp <= s_l) then
411 zone = 0
412 else if (0._wp <= s_lstar) then
413 zone = 1
414 else if (0._wp <= s_m) then
415 zone = 2
416 else if (0._wp <= s_rstar) then
417 zone = 3
418 else if (0._wp <= s_r) then
419 zone = 4
420 else
421 zone = 5
422 end if
423
424 end function f_hlld_wave_zone
425
426 !> HLLD Riemann solver resolves all 5 waves for the hypoelastic equations: 1 entropy wave, 2 shear stress waves, 2 fast waves.
427 subroutine s_hypo_hlld_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, &
428 & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, &
429 & q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz)
430
431 real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf
432 type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, &
433 & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf
434
435 type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf
436 type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf
437 type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf
438 integer, intent(in) :: norm_dir
439 type(int_bounds_info), intent(in) :: ix, iy, iz
440
441 ! Local variables:
442
443 ! Hypo HLLD has num_fluids==2 guard -> reads alpha_* at a hard-coded index 2.
444 ! With case-opt, `num_fluids=1` makes dimension(num_fluids) length 1,
445 ! so amdflang gives a compile-time out-of-bounds error. max(num_fluids, 2) fixes it
446
447# 83 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
448 real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R
449# 85 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
450 type(riemann_states_vec3) :: vel
451 type(riemann_states) :: rho, pres, E, H
452 type(riemann_states) :: gamma, pi_inf, qv
453 type(riemann_states) :: vel_rms
454 type(riemann_states) :: c
455
456 ! HLLD speeds and intermediate state variables:
457 real(wp) :: S_L, S_R, s_M, S_Lstar, S_Rstar
458 real(wp) :: pTot_L, pTot_R, rhoL_star, rhoR_star
459 real(wp), dimension(14) :: U_L, U_R
460 real(wp), dimension(14) :: F_L, F_R, F_hlld
461 real(wp) :: us_c, uss_c ! selected-side U_star / U_starstar, one component at a time (register diet)
462 real(wp) :: F_HLL_c ! per-component HLL flux for ADC blending (diet: replaces the F_HLL array)
463 real(wp) :: U_HLL_c ! per-component HLL state for the ADC axisym trace (diet: replaces the U_HLL array)
464 real(wp) :: rho_HLL, u_n_HLL_cons, tau_nn_HLL
465 real(wp) :: u_n_HLL_trace, u_t_HLL_trace
466 real(wp) :: p_face_HLL, tau_qq_face_HLL
467 integer :: ncomp ! 11 for 2D/axisym, 14 for 3D Cartesian
468
469 ! HLLD Hypo variables
470
471 real(wp) :: G_eff, G_eff_tol, C_NC, sqrtC_NC
472 real(wp) :: A_L, A_R, denomA, fac_L, fac_R
473 real(wp) :: u_n_L, u_t_L, u_n_R, u_t_R
474 real(wp) :: u_t2_L, u_t2_R
475 real(wp) :: tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R
476 real(wp) :: tau_nt2_L, tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R
477 real(wp) :: tau_qq_L, tau_qq_R
478 real(wp) :: G_L, G_R
479# 117 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
480 real(wp), dimension(eqn_idx%stress%end - eqn_idx%stress%beg + 1) :: tau_e_L, tau_e_R
481# 119 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
482
483 real(wp) :: alpha1_L_star, alpha1_R_star, alpha2_L_star, alpha2_R_star
484 real(wp) :: u_t_star, tau_nt_star
485 real(wp) :: u_t2_star, tau_nt2_star
486 real(wp) :: tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star
487 real(wp) :: tau_tt_L_starstar, tau_tt_R_starstar
488 real(wp) :: tau_t2t2_L_star, tau_t2t2_R_star
489 real(wp) :: tau_t2t2_L_starstar, tau_t2t2_R_starstar
490 real(wp) :: tau_t1t2_L_star, tau_t1t2_R_star
491 real(wp) :: tau_t1t2_L_starstar, tau_t1t2_R_starstar
492 real(wp) :: tau_qq_L_star, tau_qq_R_star
493 real(wp) :: pTot_star
494 real(wp) :: E_L_star, E_R_star
495 real(wp) :: E_L_starstar, E_R_starstar
496 real(wp) :: p_face, tau_qq_face
497 real(wp) :: u_n_face, u_t_face
498 real(wp) :: G_hat
499 real(wp) :: rho_hat
500 real(wp) :: tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat
501 real(wp) :: tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat
502 ! alpha_hat/alpha_rho_hat: same max(num_fluids, 2) reason as alpha_* above
503# 147 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
504 real(wp), dimension(num_fluids) :: alpha_hat, alpha_rho_hat
505 real(wp), dimension(eqn_idx%stress%end - eqn_idx%stress%beg + 1) :: tau_e_hat
506# 150 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
507
508 real(wp) :: pres_hat, blkmod1_hat, blkmod2_hat, K_hat
509 real(wp) :: C_hat_1, C_hat_2
510 real(wp) :: Sigma_L, Sigma_R, dSigma, Sigma_ref
511 real(wp) :: a_L_ref, a_R_ref, a_ref
512 real(wp) :: du_t, dtau_nt, du_t2, dtau_nt2
513 real(wp) :: sensor_ptot, sensor_vt, sensor_tnt, sensor_combined
514 real(wp) :: phi
515 real(wp), parameter :: ADC_power = 1.0_wp
516 real(wp) :: alpha_L_sum, alpha_R_sum
517 logical :: degenerate, shear_degenerate, fan_fallback
518 integer :: i, j, k, l, ipass, zone
519
520 call s_populate_riemann_states_variables_buffers(ql_prim_rsx_vf, dql_prim_dx_vf, dql_prim_dy_vf, dql_prim_dz_vf, &
521 & qr_prim_rsx_vf, dqr_prim_dx_vf, dqr_prim_dy_vf, dqr_prim_dz_vf, norm_dir, ix, iy, iz)
522
523 call s_initialize_riemann_solver(flux_src_vf, norm_dir)
524
525# 172 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
526# 173 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
527# 174 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
528 if (norm_dir == 1) then
529 ! Anchor-cell index pattern: the fused kernel reads both anchors (hat_L: face cell, hat_R: face cell + 1)
530 ! directly from q_prim_vf; loop indices are physical, so the offset rides the stencil index.
531# 178 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
532 ! The fused HLLD kernel privatizes ~150 scalars -- a private() list large enough that
533 ! the single clause must be wrapped across continuation lines. The four fragments
534 ! (_hlld_p1..p4) are ONLY for source readability; fypp concatenates them into one
535 ! clause below. That wrapping is FOLD_DIRECTIVE's job -- its within-clause comma split
536 ! exists for exactly this case -- not the fragments'.
537# 184 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
538# 185 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
539# 186 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
540# 187 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
541 ! Wave-fan side table for the per-component F_hlld fold below: side name, the side's two zones,
542 ! its starstar zone, and the outer/inner wave speeds. The L and R sides are mirror images.
543# 190 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
544 ! Wave-fan component tables for the per-component fold below: (us, uss) expression pairs in
545 ! F_hlld component order; uss = None means the inner (starstar) correction leaves the
546 ! component unchanged (uss_c = us_c). '{S}' expands to the fan side (L/R).
547# 207 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
548# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
549
550# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
551
552# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
553#if defined(MFC_OpenACC)
554# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
555!$acc parallel loop collapse(3) gang vector default(present) private(i, j, k, l, ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, &
556# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
557!$acc& gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, &
558# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
559!$acc& tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, &
560# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
561!$acc& tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, &
562# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
563!$acc& alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, &
564# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
565!$acc& tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, &
566# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
567!$acc& E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, &
568# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
569!$acc& alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, &
570# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
571!$acc& sensor_ptot, sensor_vt, sensor_tnt, sensor_combined, phi, alpha_L_sum, alpha_R_sum)
572# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
573#elif defined(MFC_OpenMP)
574# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
575
576# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
577
578# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
579
580# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
581!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(i, j, k, l, &
582# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
583!$omp& ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, &
584# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
585!$omp& pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, &
586# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
587!$omp& ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, &
588# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
589!$omp& tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, &
590# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
591!$omp& u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, &
592# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
593!$omp& tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, &
594# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
595!$omp& tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, &
596# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
597!$omp& blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, sensor_ptot, sensor_vt, sensor_tnt, &
598# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
599!$omp& sensor_combined, phi, alpha_L_sum, alpha_R_sum)
600# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
601#endif
602 do l = is3%beg, is3%end
603 do k = is2%beg, is2%end
604 do j = is1%beg, is1%end
605 ! Extract left/right primitive states
606
607 do i = 1, eqn_idx%cont%end
608 alpha_rho_l(i) = ql_prim_rsx_vf(j, k, l, i)
609 alpha_rho_r(i) = qr_prim_rsx_vf(j + 1, k, l, i)
610 end do
611
612 ! Initialize the unused third velocity component in 2D
613 vel%L = 0._wp
614 vel%R = 0._wp
615
616 ! Load velocities in physical-coordinate order; map directional aliases below via dir_idx
617 do i = 1, num_vels
618 vel%L(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%cont%end + i)
619 vel%R(i) = qr_prim_rsx_vf(j + 1, k, l, eqn_idx%cont%end + i)
620 end do
621
622 vel_rms%L = vel%L(1)**2 + vel%L(2)**2 + vel%L(3)**2
623 vel_rms%R = vel%R(1)**2 + vel%R(2)**2 + vel%R(3)**2
624
625 do i = 1, num_fluids
626 alpha_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%E + i)
627 alpha_r(i) = qr_prim_rsx_vf(j + 1, k, l, eqn_idx%E + i)
628 end do
629
630 ! Clamp and renormalize volume fractions when mpp_lim is on (match HLL/HLLC)
631 alpha_l_sum = 0._wp
632 alpha_r_sum = 0._wp
633 if (mpp_lim) then
634 do i = 1, num_fluids
635 alpha_rho_l(i) = max(0._wp, alpha_rho_l(i))
636 alpha_l(i) = min(max(0._wp, alpha_l(i)), 1._wp)
637 alpha_l_sum = alpha_l_sum + alpha_l(i)
638 end do
639 alpha_l = alpha_l/max(alpha_l_sum, sgm_eps)
640
641 do i = 1, num_fluids
642 alpha_rho_r(i) = max(0._wp, alpha_rho_r(i))
643 alpha_r(i) = min(max(0._wp, alpha_r(i)), 1._wp)
644 alpha_r_sum = alpha_r_sum + alpha_r(i)
645 end do
646 alpha_r = alpha_r/max(alpha_r_sum, sgm_eps)
647 end if
648
649 pres%L = ql_prim_rsx_vf(j, k, l, eqn_idx%E)
650 pres%R = qr_prim_rsx_vf(j + 1, k, l, eqn_idx%E)
651
652 ! Hypoelasticity
653
654# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
655#if defined(MFC_OpenACC)
656# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
657!$acc loop seq
658# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
659#elif defined(MFC_OpenMP)
660# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
661
662# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
663#endif
664 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
665 tau_e_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%stress%beg - 1 + i)
666 tau_e_r(i) = qr_prim_rsx_vf(j + 1, k, l, eqn_idx%stress%beg - 1 + i)
667 end do
668
669 u_t2_l = 0._wp; u_t2_r = 0._wp
670 tau_nt2_l = 0._wp; tau_nt2_r = 0._wp
671 tau_t2t2_l = 0._wp; tau_t2t2_r = 0._wp
672 tau_t1t2_l = 0._wp; tau_t1t2_r = 0._wp
673
674 ! Map physical-basis arrays to directional aliases via stress_perm/dir_idx
675 u_n_l = vel%L(dir_idx(1)); u_n_r = vel%R(dir_idx(1))
676 tau_nn_l = tau_e_l(stress_perm(1)); tau_nn_r = tau_e_r(stress_perm(1))
677 if (n == 0) then
678 ncomp = 11
679 else if (p == 0) then
680 ncomp = 11
681 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
682 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
683 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
684 else
685 ncomp = 14
686 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
687 u_t2_l = vel%L(dir_idx(3)); u_t2_r = vel%R(dir_idx(3))
688 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
689 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
690 tau_nt2_l = tau_e_l(stress_perm(4)); tau_nt2_r = tau_e_r(stress_perm(4))
691 tau_t1t2_l = tau_e_l(stress_perm(5)); tau_t1t2_r = tau_e_r(stress_perm(5))
692 tau_t2t2_l = tau_e_l(stress_perm(6)); tau_t2t2_r = tau_e_r(stress_perm(6))
693 end if
694 if (cyl_coord) then
695 tau_qq_l = tau_e_l(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
696 tau_qq_r = tau_e_r(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
697 else
698 tau_qq_l = 0._wp; tau_qq_r = 0._wp
699 end if
700 ! Total pressure (replace the usual pressure to define SM)
701 ptot_l = pres%L - tau_nn_l
702 ptot_r = pres%R - tau_nn_r
703
704 ! Symmetrize total pressure when it differs only by floating-point roundoff. WENO reconstruction of a
705 ! uniform field can produce slightly different L/R values at material interfaces due to different
706 ! smoothness indicators. With stiff materials (G~1e9), even 1e-12 relative pTot asymmetry creates O(1)
707 ! spurious stress through the HLLD star-state.
708 if (abs(ptot_r - ptot_l) < 1e-12_wp*max(abs(ptot_l), abs(ptot_r), 1._wp)) then
709 ptot_l = 5e-1_wp*(ptot_l + ptot_r)
710 ptot_r = ptot_l
711 end if
712
713 ! Sum properties of all fluid components
714 rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp
715 rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp
716
717# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
718#if defined(MFC_OpenACC)
719# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
720!$acc loop seq
721# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
722#elif defined(MFC_OpenMP)
723# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
724
725# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
726#endif
727 do i = 1, num_fluids
728 rho%L = rho%L + alpha_rho_l(i)
729 gamma%L = gamma%L + alpha_l(i)*gammas(i)
730 pi_inf%L = pi_inf%L + alpha_l(i)*pi_infs(i)
731 qv%L = qv%L + alpha_rho_l(i)*qvs(i)
732
733 rho%R = rho%R + alpha_rho_r(i)
734 gamma%R = gamma%R + alpha_r(i)*gammas(i)
735 pi_inf%R = pi_inf%R + alpha_r(i)*pi_infs(i)
736 qv%R = qv%R + alpha_rho_r(i)*qvs(i)
737 end do
738
739 g_l = 0._wp; g_r = 0._wp
740
741# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
742#if defined(MFC_OpenACC)
743# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
744!$acc loop seq
745# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
746#elif defined(MFC_OpenMP)
747# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
748
749# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
750#endif
751 do i = 1, num_fluids
752 g_l = g_l + alpha_l(i)*gs_rs(i)
753 g_r = g_r + alpha_r(i)*gs_rs(i)
754 end do
755
756 e%L = gamma%L*pres%L + pi_inf%L + 5e-1_wp*rho%L*vel_rms%L + qv%L
757 e%R = gamma%R*pres%R + pi_inf%R + 5e-1_wp*rho%R*vel_rms%R + qv%R
758
759 ! Freeze the thermal/kinetic enthalpy used by the EOS sound-speed call before
760 ! adding hypoelastic strain energy to the conservative total energy.
761 h%L = (e%L + pres%L)/rho%L
762 h%R = (e%R + pres%R)/rho%R
763
764
765# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
766#if defined(MFC_OpenACC)
767# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
768!$acc loop seq
769# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
770#elif defined(MFC_OpenMP)
771# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
772
773# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
774#endif
775 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
776 if (g_l > verysmall) then
777# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
778 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
779# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
780 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
781# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
782 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
783# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
784 end if
785# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
786 end if
787# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
788 if (g_r > verysmall) then
789# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
790 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
791# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
792 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
793# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
794 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
795# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
796 end if
797# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
798 end if
799# 356 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
800 end do
801
802 ! Compute Riemann states
803
804 call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, h%L, alpha_l, vel_rms%L, 0._wp, c%L, &
805 & qv%L)
806 call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, h%R, alpha_r, vel_rms%R, 0._wp, c%R, &
807 & qv%R)
808
809 s_l = min(u_n_l - sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)), &
810 & u_n_r - sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)))
811 s_r = max(u_n_r + sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)), &
812 & u_n_l + sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)))
813
814 if (p > 0 .and. .not. cyl_coord) then
815 ! 3D Cartesian: 14-state compact basis
816 u_l(1) = alpha_rho_l(1); u_r(1) = alpha_rho_r(1)
817 u_l(2) = alpha_rho_l(2); u_r(2) = alpha_rho_r(2)
818 u_l(3) = rho%L*u_n_l; u_r(3) = rho%R*u_n_r
819 u_l(4) = rho%L*u_t_l; u_r(4) = rho%R*u_t_r
820 u_l(5) = rho%L*u_t2_l; u_r(5) = rho%R*u_t2_r
821 u_l(6) = e%L; u_r(6) = e%R
822 u_l(7) = alpha_l(1); u_r(7) = alpha_r(1)
823 u_l(8) = alpha_l(2); u_r(8) = alpha_r(2)
824 u_l(9) = rho%L*tau_nn_l; u_r(9) = rho%R*tau_nn_r
825 u_l(10) = rho%L*tau_nt_l; u_r(10) = rho%R*tau_nt_r
826 u_l(11) = rho%L*tau_nt2_l; u_r(11) = rho%R*tau_nt2_r
827 u_l(12) = rho%L*tau_tt_l; u_r(12) = rho%R*tau_tt_r
828 u_l(13) = rho%L*tau_t2t2_l; u_r(13) = rho%R*tau_t2t2_r
829 u_l(14) = rho%L*tau_t1t2_l; u_r(14) = rho%R*tau_t1t2_r
830
831 f_l(1) = u_l(1)*u_n_l; f_r(1) = u_r(1)*u_n_r
832 f_l(2) = u_l(2)*u_n_l; f_r(2) = u_r(2)*u_n_r
833 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
834 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
835 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
836 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
837 f_l(5) = rho%L*u_n_l*u_t2_l - tau_nt2_l
838 f_r(5) = rho%R*u_n_r*u_t2_r - tau_nt2_r
839 f_l(6) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l - u_t2_l*tau_nt2_l
840 f_r(6) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r - u_t2_r*tau_nt2_r
841 ! Rows 7-14 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
842 ! inside the per-anchor pass loop below.
843 else
844 ! 2D/axisym: 11-state compact basis (unchanged)
845 u_l(1) = alpha_rho_l(1)
846 u_l(2) = alpha_rho_l(2)
847 u_l(3) = rho%L*u_n_l
848 u_l(4) = rho%L*u_t_l
849 u_l(5) = e%L
850 u_l(6) = alpha_l(1)
851 u_l(7) = alpha_l(2)
852 u_l(8) = rho%L*tau_nn_l
853 u_l(9) = rho%L*tau_nt_l
854 u_l(10) = rho%L*tau_tt_l
855 u_l(11) = rho%L*tau_qq_l
856
857 u_r(1) = alpha_rho_r(1)
858 u_r(2) = alpha_rho_r(2)
859 u_r(3) = rho%R*u_n_r
860 u_r(4) = rho%R*u_t_r
861 u_r(5) = e%R
862 u_r(6) = alpha_r(1)
863 u_r(7) = alpha_r(2)
864 u_r(8) = rho%R*tau_nn_r
865 u_r(9) = rho%R*tau_nt_r
866 u_r(10) = rho%R*tau_tt_r
867 u_r(11) = rho%R*tau_qq_r
868
869 f_l(1) = u_l(1)*u_n_l
870 f_l(2) = u_l(2)*u_n_l
871 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
872 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
873 f_l(5) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l
874
875 f_r(1) = u_r(1)*u_n_r
876 f_r(2) = u_r(2)*u_n_r
877 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
878 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
879 f_r(5) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r
880 ! Rows 6-11 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
881 ! inside the per-anchor pass loop below.
882 end if
883
884 a_l = rho%L*(s_l - u_n_l)
885 a_r = rho%R*(s_r - u_n_r)
886 denoma = (a_r - a_l)
887
888 s_m = ((ptot_r - ptot_l) + a_l*u_n_l - a_r*u_n_r)/(a_l - a_r + verysmall)
889
890 ! Degenerate wave structure: denom ~ 0 or S_M not in [S_L,S_R]. The test is anchor-independent, so both
891 ! anchored solves below take the same branch.
892 degenerate = (abs(denoma) < verysmall .or. .not. (s_l - verysmall <= s_m .and. s_m <= s_r + verysmall))
893
894 if (.not. degenerate) then
895 ! Anchor-independent pieces of the star region (the anchor state enters only the volume-fraction and
896 ! stress star states)
897 ptot_star = ptot_l + a_l*(s_m - u_n_l)
898
899 ! Signed floor (HLLC-style, see m_riemann_solver_hllc.fpp) on the wave-fan denominators: guards the
900 ! degenerate S_M -> S_L / S_M -> S_R limit, sign-preserving, and a no-op away from it (|denom| >>
901 ! verysmall)
902 rhol_star = rho%L*(s_l - u_n_l)/min(s_l - s_m, -verysmall)
903 rhor_star = rho%R*(s_r - u_n_r)/max(s_r - s_m, verysmall)
904 fac_l = (s_l - u_n_l)/min(s_l - s_m, -verysmall)
905 fac_r = (s_r - u_n_r)/max(s_r - s_m, verysmall)
906
907 e_l_star = (e%L*(u_n_l - s_l) + u_n_l*ptot_l - s_m*ptot_star)/max(s_m - s_l, verysmall)
908 e_r_star = (e%R*(u_n_r - s_r) + u_n_r*ptot_r - s_m*ptot_star)/min(s_m - s_r, -verysmall)
909
910 if (riemann_hypo_adc) then
911 ! ADC sensors depend only on the L/R face states: computed once, shared by both anchored solves
912 sigma_l = ptot_l
913 sigma_r = ptot_r
914 dsigma = sigma_r - sigma_l
915 sigma_ref = max(max(abs(sigma_l), abs(sigma_r)), verysmall)
916
917 a_l_ref = sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L))
918 a_r_ref = sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R))
919 a_ref = max(max(a_l_ref, a_r_ref), verysmall)
920
921 du_t = u_t_r - u_t_l
922 dtau_nt = tau_nt_r - tau_nt_l
923 du_t2 = u_t2_r - u_t2_l
924 dtau_nt2 = tau_nt2_r - tau_nt2_l
925
926 sensor_ptot = (dsigma*dsigma)/((adc_kappa*sigma_ref)**2 + verysmall)
927 sensor_vt = (du_t*du_t + du_t2*du_t2)/((adc_kappa*a_ref)**2 + verysmall)
928 sensor_tnt = (dtau_nt*dtau_nt + dtau_nt2*dtau_nt2)/((adc_kappa*sigma_ref)**2 + verysmall)
929
930 sensor_combined = sensor_ptot + sensor_tnt + sensor_vt
931
932 phi = exp(-(sensor_combined**adc_power))
933 end if
934 end if
935
936 ! Fused dual-pass: both anchored solves share everything above. The anchor (hat) state and everything it
937 ! touches is evaluated per pass: pass 1 anchors on cell j (hat_L) and writes the flux_rs* set; pass 2
938 ! anchors on cell j+1 (hat_R) and writes the flux_hatR_rs* set.
939
940# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
941#if defined(MFC_OpenACC)
942# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
943!$acc loop seq
944# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
945#elif defined(MFC_OpenMP)
946# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
947
948# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
949#endif
950 do ipass = 1, 2
951 do i = 1, eqn_idx%cont%end
952 alpha_rho_hat(i) = q_prim_vf(i)%sf(j + ipass - 1, k, l)
953 end do
954 do i = 1, num_fluids
955 alpha_hat(i) = q_prim_vf(eqn_idx%E + i)%sf(j + ipass - 1, k, l)
956 end do
957
958# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
959#if defined(MFC_OpenACC)
960# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
961!$acc loop seq
962# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
963#elif defined(MFC_OpenMP)
964# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
965
966# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
967#endif
968 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
969 tau_e_hat(i) = q_prim_vf(eqn_idx%stress%beg - 1 + i)%sf(j + ipass - 1, k, l)
970 end do
971
972 ! Anchor-state directional aliases (mirrors the L/R alias block above)
973 tau_nt2_hat = 0._wp; tau_t2t2_hat = 0._wp; tau_t1t2_hat = 0._wp
974 tau_nn_hat = tau_e_hat(stress_perm(1))
975 if (n > 0) then
976 tau_nt_hat = tau_e_hat(stress_perm(2))
977 tau_tt_hat = tau_e_hat(stress_perm(3))
978 if (p > 0) then
979 tau_nt2_hat = tau_e_hat(stress_perm(4))
980 tau_t1t2_hat = tau_e_hat(stress_perm(5))
981 tau_t2t2_hat = tau_e_hat(stress_perm(6))
982 end if
983 end if
984 if (cyl_coord) then
985 tau_qq_hat = tau_e_hat(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
986 else
987 tau_qq_hat = 0._wp
988 end if
989
990 rho_hat = 0._wp
991
992# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
993#if defined(MFC_OpenACC)
994# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
995!$acc loop seq
996# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
997#elif defined(MFC_OpenMP)
998# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
999
1000# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1001#endif
1002 do i = 1, num_fluids
1003 rho_hat = rho_hat + alpha_rho_hat(i)
1004 end do
1005
1006 g_hat = 0._wp
1007
1008# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1009#if defined(MFC_OpenACC)
1010# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1011!$acc loop seq
1012# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1013#elif defined(MFC_OpenMP)
1014# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1015
1016# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1017#endif
1018 do i = 1, num_fluids
1019 g_hat = g_hat + alpha_hat(i)*gs_rs(i)
1020 end do
1021
1022 ! Two-component 2D only (enforced by checker restrictions)
1023 k_hat = 0._wp
1024 if (alt_soundspeed) then
1025 pres_hat = q_prim_vf(eqn_idx%E)%sf(j + ipass - 1, k, l)
1026 blkmod1_hat = ((gammas(1) + 1._wp)*pres_hat + pi_infs(1))/gammas(1) + (4._wp/3._wp)*gs_rs(1)
1027 blkmod2_hat = ((gammas(2) + 1._wp)*pres_hat + pi_infs(2))/gammas(2) + (4._wp/3._wp)*gs_rs(2)
1028 k_hat = alpha_hat(1)*alpha_hat(2)*(blkmod2_hat - blkmod1_hat)/(alpha_hat(1)*blkmod2_hat &
1029 & + alpha_hat(2)*blkmod1_hat + verysmall)
1030 end if
1031 c_hat_1 = alpha_hat(1) + k_hat
1032 c_hat_2 = alpha_hat(2) - k_hat
1033
1034 if (p > 0 .and. .not. cyl_coord) then
1035 ! 3D Cartesian: anchor-dependent rows (7-14) of the 14-state flux
1036 f_l(7) = u_l(7)*u_n_l - c_hat_1*u_n_l
1037 f_r(7) = u_r(7)*u_n_r - c_hat_1*u_n_r
1038 f_l(8) = u_l(8)*u_n_l - c_hat_2*u_n_l
1039 f_r(8) = u_r(8)*u_n_r - c_hat_2*u_n_r
1040 f_l(9) = u_l(9)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
1041 f_r(9) = u_r(9)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
1042 f_l(10) = u_l(10)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
1043 f_r(10) = u_r(10)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
1044 f_l(11) = u_l(11)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t2_l
1045 f_r(11) = u_r(11)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t2_r
1046 f_l(12) = u_l(12)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
1047 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
1048 f_r(12) = u_r(12)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
1049 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
1050 f_l(13) = u_l(13)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_l &
1051 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_l
1052 f_r(13) = u_r(13)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_r &
1053 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_r
1054 f_l(14) = u_l(14)*u_n_l + rho_hat*tau_t1t2_hat*u_n_l - rho_hat*tau_nt2_hat*u_t_l &
1055 & - rho_hat*tau_nt_hat*u_t2_l
1056 f_r(14) = u_r(14)*u_n_r + rho_hat*tau_t1t2_hat*u_n_r - rho_hat*tau_nt2_hat*u_t_r &
1057 & - rho_hat*tau_nt_hat*u_t2_r
1058 else
1059 ! 2D/axisym: anchor-dependent rows (6-11) of the 11-state flux
1060 f_l(6) = u_l(6)*u_n_l - c_hat_1*u_n_l
1061 f_r(6) = u_r(6)*u_n_r - c_hat_1*u_n_r
1062 f_l(7) = u_l(7)*u_n_l - c_hat_2*u_n_l
1063 f_r(7) = u_r(7)*u_n_r - c_hat_2*u_n_r
1064 f_l(8) = u_l(8)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
1065 f_r(8) = u_r(8)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
1066 f_l(9) = u_l(9)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
1067 f_r(9) = u_r(9)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
1068 f_l(10) = u_l(10)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
1069 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
1070 f_r(10) = u_r(10)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
1071 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
1072 f_l(11) = u_l(11)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_l
1073 f_r(11) = u_r(11)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_r
1074 end if
1075
1076 ! The effective shear stiffness is anchor-dependent. Resolve its three numerical states before
1077 ! forming C_NC: positive keeps HLLD; zero to cancellation accuracy takes the finite HLLC limit;
1078 ! materially negative (loss of the assumed real shear subfan) rejects the whole anchored fan.
1079 ! The tolerance is relative only to the two terms being added, not to an acoustic/material scale.
1080 fan_fallback = degenerate
1081 shear_degenerate = .false.
1082 if (.not. fan_fallback) then
1083 g_eff = g_hat + tau_nn_hat
1084 g_eff_tol = g_eff_roundoff_factor*epsilon(1._wp)*(abs(g_hat) + abs(tau_nn_hat))
1085
1086 if (.not. (g_eff >= -g_eff_tol)) then
1087 ! Materially negative, or unordered (NaN): no real five-wave shear fan.
1088 fan_fallback = .true.
1089 else if (g_eff <= g_eff_tol) then
1090 shear_degenerate = .true.
1091 s_lstar = s_m
1092 s_rstar = s_m
1093 else
1094 c_nc = rho_hat*g_eff
1095 if (.not. (c_nc > 0._wp)) then
1096 ! Positive G_eff below the representable C_NC range is numerically degenerate;
1097 ! nonpositive/unordered rho_hat is invalid for the same construction.
1098 shear_degenerate = (rho_hat > 0._wp)
1099 fan_fallback = .not. shear_degenerate
1100 s_lstar = s_m
1101 s_rstar = s_m
1102 else
1103 sqrtc_nc = sqrt(c_nc)
1104 s_lstar = s_m - sqrtc_nc/rhol_star
1105 s_rstar = s_m + sqrtc_nc/rhor_star
1106 ! A speed-only clamp would break the corresponding Rankine--Hugoniot jump.
1107 fan_fallback = (s_lstar < s_l .or. s_rstar > s_r)
1108 end if
1109 end if
1110 end if
1111
1112 if (fan_fallback) then
1113 ! HLL (or one-sided) fallback for an invalid wave structure
1114 if (s_l < 0._wp .and. s_r > 0._wp) then
1115 do i = 1, ncomp
1116 f_hlld(i) = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
1117 end do
1118 else if (s_l >= 0._wp) then
1119 f_hlld(1:ncomp) = f_l(1:ncomp)
1120 else
1121 f_hlld(1:ncomp) = f_r(1:ncomp)
1122 end if
1123 ! Initialize star-state variables to safe values so no path reads uninitialized memory
1124 ! (a subsequent valid pass restores what it needs). Fallback face exports do not use
1125 ! them: they take the HLL/one-sided traces computed below.
1126 ptot_star = 5e-1_wp*(ptot_l + ptot_r)
1127 s_lstar = s_l
1128 s_rstar = s_r
1129 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
1130 tau_nn_l_star = tau_nn_l
1131 tau_nn_r_star = tau_nn_r
1132 tau_qq_l_star = tau_qq_l
1133 tau_qq_r_star = tau_qq_r
1134 else
1135 ! A preceding anchored pass may have taken the fallback and assigned a safe face value.
1136 ! Restore the anchor-independent HLLD contact pressure for this valid pass.
1137 ptot_star = ptot_l + a_l*(s_m - u_n_l)
1138
1139 if (shear_degenerate) then
1140 ! Degenerate shear impedance: collapse inner waves to HLLC
1141 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
1142 tau_nt_star = 5e-1_wp*(tau_nt_l + tau_nt_r)
1143 u_t2_star = 5e-1_wp*(u_t2_l + u_t2_r)
1144 tau_nt2_star = 5e-1_wp*(tau_nt2_l + tau_nt2_r)
1145 else
1146 u_t_star = 5e-1_wp*((tau_nt_r - tau_nt_l)/sqrtc_nc + (u_t_r + u_t_l))
1147 tau_nt_star = 5e-1_wp*((u_t_r - u_t_l)*sqrtc_nc + (tau_nt_r + tau_nt_l))
1148 u_t2_star = 5e-1_wp*((tau_nt2_r - tau_nt2_l)/sqrtc_nc + (u_t2_r + u_t2_l))
1149 tau_nt2_star = 5e-1_wp*((u_t2_r - u_t2_l)*sqrtc_nc + (tau_nt2_r + tau_nt2_l))
1150 end if
1151
1152 ! Outer-wave stress star states: one formula family over the components. ELC is
1153 ! the anchor-side elastic coefficient (deviatoric 4/3 vs 2/3 structure; t1t2
1154 ! carries no G term) and SGN = -1/+1 the jump sign of the component.
1155# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1156# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1157 tau_nn_l_star = tau_nn_l - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
1158# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1159 tau_nn_r_star = tau_nn_r - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
1160# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1161# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1162# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1163 tau_tt_l_star = tau_tt_l + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
1164# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1165 tau_tt_r_star = tau_tt_r + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
1166# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1167# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1168# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1169 tau_t2t2_l_star = tau_t2t2_l + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
1170# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1171 tau_t2t2_r_star = tau_t2t2_r + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
1172# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1173# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1174# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1175 tau_t1t2_l_star = tau_t1t2_l + (rho_hat*tau_t1t2_hat*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
1176# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1177 tau_t1t2_r_star = tau_t1t2_r + (rho_hat*tau_t1t2_hat*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
1178# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1179# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1180# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1181 tau_qq_l_star = tau_qq_l + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
1182# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1183 tau_qq_r_star = tau_qq_r + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
1184# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1185# 680 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1186
1187 if (shear_degenerate) then
1188 ! Degenerate: no inner wave correction
1189 tau_tt_l_starstar = tau_tt_l_star
1190 tau_tt_r_starstar = tau_tt_r_star
1191 tau_t2t2_l_starstar = tau_t2t2_l_star
1192 tau_t2t2_r_starstar = tau_t2t2_r_star
1193 tau_t1t2_l_starstar = tau_t1t2_l_star
1194 tau_t1t2_r_starstar = tau_t1t2_r_star
1195 e_l_starstar = e_l_star
1196 e_r_starstar = e_r_star
1197 else
1198 tau_tt_l_starstar = tau_tt_l_star + 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_l)
1199 tau_tt_r_starstar = tau_tt_r_star - 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_r)
1200 tau_t2t2_l_starstar = tau_t2t2_l_star + 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
1201 & - u_t2_l)
1202 tau_t2t2_r_starstar = tau_t2t2_r_star - 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
1203 & - u_t2_r)
1204 tau_t1t2_l_starstar = tau_t1t2_l_star + rho_hat*(tau_nt2_hat*(u_t_star - u_t_l) &
1205 & + tau_nt_hat*(u_t2_star - u_t2_l))/sqrtc_nc
1206 tau_t1t2_r_starstar = tau_t1t2_r_star - rho_hat*(tau_nt2_hat*(u_t_star - u_t_r) &
1207 & + tau_nt_hat*(u_t2_star - u_t2_r))/sqrtc_nc
1208 e_l_starstar = e_l_star + (rhol_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_l*tau_nt_l) &
1209 & + (u_t2_star*tau_nt2_star - u_t2_l*tau_nt2_l))
1210 e_r_starstar = e_r_star - (rhor_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_r*tau_nt_r) &
1211 & + (u_t2_star*tau_nt2_star - u_t2_r*tau_nt2_r))
1212 end if
1213
1214 alpha1_l_star = (alpha_l(1)*(s_l - u_n_l) - c_hat_1*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
1215 alpha1_r_star = (alpha_r(1)*(s_r - u_n_r) - c_hat_1*(s_m - u_n_r))/max(s_r - s_m, verysmall)
1216
1217 alpha2_l_star = (alpha_l(2)*(s_l - u_n_l) - c_hat_2*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
1218 alpha2_r_star = (alpha_r(2)*(s_r - u_n_r) - c_hat_2*(s_m - u_n_r))/max(s_r - s_m, verysmall)
1219
1220 ! HLLD flux, register-diet form: pick the wave-fan zone once (it is
1221 ! component-independent), then fold the selected side's star/starstar states into
1222 ! F_hlld one component at a time through the scalars us_c/uss_c (no fan arrays
1223 ! survive). The L and R sides are mirror images and the per-component statements
1224 ! share one shape, so the whole fold is emitted from one Fypp template driven by
1225 ! HLLD_FAN_SIDES and the HLLD_FAN_COMPS_3D/2D tables above. Per-component operation
1226 ! order matches the materialized form, so the flux is -O0 bit-identical. Do NOT
1227 ! re-expand into per-region temp arrays (or reorder the fold) without re-checking
1228 ! GPU register spill and the -O0 exactness gate.
1229
1230 zone = f_hlld_wave_zone(s_l, s_lstar, s_m, s_rstar, s_r)
1231
1232 if (zone == 0) then
1233 f_hlld(1:ncomp) = f_l(1:ncomp)
1234 else if (zone == 5) then
1235 f_hlld(1:ncomp) = f_r(1:ncomp)
1236# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1237 else if (zone == 1 .or. zone == 2) then
1238 ! L side of the fan: per component, us_c/uss_c are the selected side's
1239 ! star/starstar states (the old F_starL is folded into the first F_hlld
1240 ! statement; the starstar correction applies in zone 2 only, with the
1241 ! left-associative order of the materialized form preserved)
1242 if (p > 0 .and. .not. cyl_coord) then
1243# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1244 us_c = u_l(1)*fac_l
1245 uss_c = us_c
1246 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
1247 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
1248 & - us_c)
1249# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1250 us_c = u_l(2)*fac_l
1251 uss_c = us_c
1252 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
1253 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
1254 & - us_c)
1255# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1256 us_c = rhol_star*s_m
1257 uss_c = us_c
1258 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
1259 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
1260 & - us_c)
1261# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1262 us_c = rhol_star*u_t_l
1263 uss_c = rhol_star*u_t_star
1264 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
1265 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
1266 & - us_c)
1267# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1268 us_c = rhol_star*u_t2_l
1269 uss_c = rhol_star*u_t2_star
1270 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
1271 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
1272 & - us_c)
1273# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1274 us_c = e_l_star
1275 uss_c = e_l_starstar
1276 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
1277 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
1278 & - us_c)
1279# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1280 us_c = alpha1_l_star
1281 uss_c = us_c
1282 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
1283 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
1284 & - us_c)
1285# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1286 us_c = alpha2_l_star
1287 uss_c = us_c
1288 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
1289 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
1290 & - us_c)
1291# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1292 us_c = rhol_star*tau_nn_l_star
1293 uss_c = us_c
1294 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
1295 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
1296 & - us_c)
1297# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1298 us_c = rhol_star*tau_nt_l
1299 uss_c = rhol_star*tau_nt_star
1300 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
1301 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
1302 & - us_c)
1303# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1304 us_c = rhol_star*tau_nt2_l
1305 uss_c = rhol_star*tau_nt2_star
1306 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
1307 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
1308 & - us_c)
1309# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1310 us_c = rhol_star*tau_tt_l_star
1311 uss_c = rhol_star*tau_tt_l_starstar
1312 f_hlld(12) = f_l(12) + s_l*(us_c - u_l(12))
1313 if (zone == 2) f_hlld(12) = f_hlld(12) + s_lstar*(uss_c &
1314 & - us_c)
1315# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1316 us_c = rhol_star*tau_t2t2_l_star
1317 uss_c = rhol_star*tau_t2t2_l_starstar
1318 f_hlld(13) = f_l(13) + s_l*(us_c - u_l(13))
1319 if (zone == 2) f_hlld(13) = f_hlld(13) + s_lstar*(uss_c &
1320 & - us_c)
1321# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1322 us_c = rhol_star*tau_t1t2_l_star
1323 uss_c = rhol_star*tau_t1t2_l_starstar
1324 f_hlld(14) = f_l(14) + s_l*(us_c - u_l(14))
1325 if (zone == 2) f_hlld(14) = f_hlld(14) + s_lstar*(uss_c &
1326 & - us_c)
1327# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1328 else
1329# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1330 us_c = u_l(1)*fac_l
1331 uss_c = us_c
1332 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
1333 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
1334 & - us_c)
1335# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1336 us_c = u_l(2)*fac_l
1337 uss_c = us_c
1338 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
1339 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
1340 & - us_c)
1341# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1342 us_c = rhol_star*s_m
1343 uss_c = us_c
1344 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
1345 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
1346 & - us_c)
1347# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1348 us_c = rhol_star*u_t_l
1349 uss_c = rhol_star*u_t_star
1350 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
1351 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
1352 & - us_c)
1353# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1354 us_c = e_l_star
1355 uss_c = e_l_starstar
1356 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
1357 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
1358 & - us_c)
1359# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1360 us_c = alpha1_l_star
1361 uss_c = us_c
1362 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
1363 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
1364 & - us_c)
1365# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1366 us_c = alpha2_l_star
1367 uss_c = us_c
1368 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
1369 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
1370 & - us_c)
1371# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1372 us_c = rhol_star*tau_nn_l_star
1373 uss_c = us_c
1374 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
1375 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
1376 & - us_c)
1377# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1378 us_c = rhol_star*tau_nt_l
1379 uss_c = rhol_star*tau_nt_star
1380 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
1381 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
1382 & - us_c)
1383# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1384 us_c = rhol_star*tau_tt_l_star
1385 uss_c = rhol_star*tau_tt_l_starstar
1386 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
1387 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
1388 & - us_c)
1389# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1390 us_c = rhol_star*tau_qq_l_star
1391 uss_c = us_c
1392 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
1393 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
1394 & - us_c)
1395# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1396 end if
1397# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1398 else if (zone == 3 .or. zone == 4) then
1399 ! R side of the fan: per component, us_c/uss_c are the selected side's
1400 ! star/starstar states (the old F_starR is folded into the first F_hlld
1401 ! statement; the starstar correction applies in zone 3 only, with the
1402 ! left-associative order of the materialized form preserved)
1403 if (p > 0 .and. .not. cyl_coord) then
1404# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1405 us_c = u_r(1)*fac_r
1406 uss_c = us_c
1407 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
1408 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
1409 & - us_c)
1410# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1411 us_c = u_r(2)*fac_r
1412 uss_c = us_c
1413 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
1414 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
1415 & - us_c)
1416# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1417 us_c = rhor_star*s_m
1418 uss_c = us_c
1419 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
1420 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
1421 & - us_c)
1422# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1423 us_c = rhor_star*u_t_r
1424 uss_c = rhor_star*u_t_star
1425 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
1426 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
1427 & - us_c)
1428# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1429 us_c = rhor_star*u_t2_r
1430 uss_c = rhor_star*u_t2_star
1431 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
1432 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
1433 & - us_c)
1434# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1435 us_c = e_r_star
1436 uss_c = e_r_starstar
1437 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
1438 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
1439 & - us_c)
1440# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1441 us_c = alpha1_r_star
1442 uss_c = us_c
1443 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
1444 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
1445 & - us_c)
1446# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1447 us_c = alpha2_r_star
1448 uss_c = us_c
1449 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
1450 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
1451 & - us_c)
1452# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1453 us_c = rhor_star*tau_nn_r_star
1454 uss_c = us_c
1455 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
1456 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
1457 & - us_c)
1458# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1459 us_c = rhor_star*tau_nt_r
1460 uss_c = rhor_star*tau_nt_star
1461 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
1462 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
1463 & - us_c)
1464# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1465 us_c = rhor_star*tau_nt2_r
1466 uss_c = rhor_star*tau_nt2_star
1467 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
1468 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
1469 & - us_c)
1470# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1471 us_c = rhor_star*tau_tt_r_star
1472 uss_c = rhor_star*tau_tt_r_starstar
1473 f_hlld(12) = f_r(12) + s_r*(us_c - u_r(12))
1474 if (zone == 3) f_hlld(12) = f_hlld(12) + s_rstar*(uss_c &
1475 & - us_c)
1476# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1477 us_c = rhor_star*tau_t2t2_r_star
1478 uss_c = rhor_star*tau_t2t2_r_starstar
1479 f_hlld(13) = f_r(13) + s_r*(us_c - u_r(13))
1480 if (zone == 3) f_hlld(13) = f_hlld(13) + s_rstar*(uss_c &
1481 & - us_c)
1482# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1483 us_c = rhor_star*tau_t1t2_r_star
1484 uss_c = rhor_star*tau_t1t2_r_starstar
1485 f_hlld(14) = f_r(14) + s_r*(us_c - u_r(14))
1486 if (zone == 3) f_hlld(14) = f_hlld(14) + s_rstar*(uss_c &
1487 & - us_c)
1488# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1489 else
1490# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1491 us_c = u_r(1)*fac_r
1492 uss_c = us_c
1493 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
1494 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
1495 & - us_c)
1496# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1497 us_c = u_r(2)*fac_r
1498 uss_c = us_c
1499 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
1500 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
1501 & - us_c)
1502# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1503 us_c = rhor_star*s_m
1504 uss_c = us_c
1505 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
1506 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
1507 & - us_c)
1508# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1509 us_c = rhor_star*u_t_r
1510 uss_c = rhor_star*u_t_star
1511 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
1512 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
1513 & - us_c)
1514# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1515 us_c = e_r_star
1516 uss_c = e_r_starstar
1517 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
1518 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
1519 & - us_c)
1520# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1521 us_c = alpha1_r_star
1522 uss_c = us_c
1523 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
1524 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
1525 & - us_c)
1526# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1527 us_c = alpha2_r_star
1528 uss_c = us_c
1529 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
1530 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
1531 & - us_c)
1532# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1533 us_c = rhor_star*tau_nn_r_star
1534 uss_c = us_c
1535 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
1536 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
1537 & - us_c)
1538# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1539 us_c = rhor_star*tau_nt_r
1540 uss_c = rhor_star*tau_nt_star
1541 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
1542 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
1543 & - us_c)
1544# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1545 us_c = rhor_star*tau_tt_r_star
1546 uss_c = rhor_star*tau_tt_r_starstar
1547 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
1548 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
1549 & - us_c)
1550# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1551 us_c = rhor_star*tau_qq_r_star
1552 uss_c = us_c
1553 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
1554 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
1555 & - us_c)
1556# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1557 end if
1558# 754 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1559 end if
1560
1561 ! ADC blending (HLLD / HLL)
1562
1563 if (riemann_hypo_adc) then
1564 ! Register-diet form: the HLL flux enters per component as the scalar F_HLL_c
1565 ! instead of a materialized F_HLL array; outside the subsonic fan F_HLL equals
1566 ! F_hlld and the identity blend is kept explicitly so the arithmetic (including
1567 ! signed-zero behavior) matches the array form bit-for-bit.
1568 ! phi is anchor-independent: computed once in the shared section above
1569 if (s_l < 0._wp .and. s_r > 0._wp) then
1570 do i = 1, ncomp
1571 f_hll_c = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
1572 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
1573 end do
1574 else
1575 do i = 1, ncomp
1576 f_hll_c = f_hlld(i)
1577 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
1578 end do
1579 end if
1580 end if
1581 end if
1582
1583 ! HLL face traces for the axisymmetric completion: consumed by the ADC face-state blend on
1584 ! valid fans and by the face exports on fallback faces (whose conservative flux is the
1585 ! matching HLL/one-sided flux). Rows 8/11 carry the pass's anchored folds, so the traces
1586 ! are anchor-dependent, like the ADC reference they generalize.
1587 if (cyl_coord .and. (riemann_hypo_adc .or. fan_fallback)) then
1588 if (0._wp <= s_l) then
1589 u_n_hll_trace = u_n_l; u_t_hll_trace = u_t_l
1590 p_face_hll = pres%L; tau_qq_face_hll = tau_qq_l
1591 else if (s_r <= 0._wp) then
1592 u_n_hll_trace = u_n_r; u_t_hll_trace = u_t_r
1593 p_face_hll = pres%R; tau_qq_face_hll = tau_qq_r
1594 else
1595 u_n_hll_trace = (s_r*u_n_l - s_l*u_n_r)/(s_r - s_l + verysmall)
1596 u_t_hll_trace = (s_r*u_t_l - s_l*u_t_r)/(s_r - s_l + verysmall)
1597 ! Only HLL-state components 1, 2, 3, 8 and 11 feed the axisym trace
1598 u_hll_c = (s_r*u_r(1) - s_l*u_l(1) - (f_r(1) - f_l(1)))/(s_r - s_l + verysmall)
1599 rho_hll = u_hll_c
1600 u_hll_c = (s_r*u_r(2) - s_l*u_l(2) - (f_r(2) - f_l(2)))/(s_r - s_l + verysmall)
1601 rho_hll = rho_hll + u_hll_c
1602 u_hll_c = (s_r*u_r(3) - s_l*u_l(3) - (f_r(3) - f_l(3)))/(s_r - s_l + verysmall)
1603 u_n_hll_cons = u_hll_c/(rho_hll + verysmall)
1604 u_hll_c = (s_r*u_r(8) - s_l*u_l(8) - (f_r(8) - f_l(8)))/(s_r - s_l + verysmall)
1605 tau_nn_hll = u_hll_c/(rho_hll + verysmall)
1606 u_hll_c = (s_r*u_r(11) - s_l*u_l(11) - (f_r(11) - f_l(11)))/(s_r - s_l + verysmall)
1607 tau_qq_face_hll = u_hll_c/(rho_hll + verysmall)
1608 ! This branch implies S_L < 0 < S_R, so component 3 of F_HLL is the interior HLL flux
1609 f_hll_c = (s_r*f_l(3) - s_l*f_r(3) + s_l*s_r*(u_r(3) - u_l(3)))/(s_r - s_l + verysmall)
1610 p_face_hll = f_hll_c - rho_hll*u_n_hll_cons*u_n_hll_cons + tau_nn_hll
1611 end if
1612 end if
1613
1614 ! Reorder F_HLLD for output: pass 1 (hat_L) -> flux_rs*, pass 2 (hat_R) -> flux_hatR_rs*
1615# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1616 if (ipass == 1) then
1617 if (p > 0 .and. .not. cyl_coord) then
1618 ! 3D Cartesian: 14-state -> physical indices
1619 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
1620 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
1621 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
1622 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
1623 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
1624 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
1625 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
1626 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
1627 ! Map local stress to physical stress indices
1628 if (dir_idx(1) == 1) then
1629 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
1630 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
1631 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
1632 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
1633 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
1634 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
1635 else if (dir_idx(1) == 2) then
1636 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
1637 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
1638 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
1639 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
1640 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
1641 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
1642 else
1643 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
1644 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
1645 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
1646 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
1647 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
1648 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
1649 end if
1650 else
1651 ! 2D/axisym: 11-state (unchanged)
1652 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
1653 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
1654 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
1655 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
1656 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
1657 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
1658 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
1659 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
1660 if (dir_idx(1) == 1) then
1661 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
1662 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
1663 else
1664 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
1665 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
1666 end if
1667 if (cyl_coord) then
1668 flux_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
1669 end if
1670 end if
1671 end if
1672# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1673 if (ipass == 2) then
1674 if (p > 0 .and. .not. cyl_coord) then
1675 ! 3D Cartesian: 14-state -> physical indices
1676 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
1677 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
1678 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
1679 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
1680 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
1681 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
1682 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
1683 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
1684 ! Map local stress to physical stress indices
1685 if (dir_idx(1) == 1) then
1686 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
1687 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
1688 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
1689 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
1690 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
1691 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
1692 else if (dir_idx(1) == 2) then
1693 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
1694 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
1695 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
1696 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
1697 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
1698 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
1699 else
1700 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
1701 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
1702 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
1703 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
1704 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
1705 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
1706 end if
1707 else
1708 ! 2D/axisym: 11-state (unchanged)
1709 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
1710 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
1711 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
1712 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
1713 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
1714 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
1715 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
1716 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
1717 if (dir_idx(1) == 1) then
1718 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
1719 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
1720 else
1721 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
1722 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
1723 end if
1724 if (cyl_coord) then
1725 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
1726 end if
1727 end if
1728 end if
1729# 868 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1730
1731 ! Export face velocities for axisym hypo source terms
1732 if (grid_geometry == 2) then
1733 if (fan_fallback) then
1734 ! Fallback face: the conservative flux is the HLL/one-sided flux, so export the
1735 ! matching HLL/one-sided traces, not the rejected fan's contact speed/star states
1736 u_n_face = u_n_hll_trace; u_t_face = u_t_hll_trace
1737 else
1738 ! Upwind by wave-fan wedge: the inner zones ride the contact (u_n = S_M) and the
1739 ! tangential state switches L -> star -> R across the shear waves (zones 2 and 3
1740 ! share the tangential star state)
1741 if (zone == 0) then
1742 u_n_face = u_n_l; u_t_face = u_t_l
1743 else if (zone == 1) then
1744 u_n_face = s_m; u_t_face = u_t_l
1745 else if (zone <= 3) then
1746 u_n_face = s_m; u_t_face = u_t_star
1747 else if (zone == 4) then
1748 u_n_face = s_m; u_t_face = u_t_r
1749 else
1750 u_n_face = u_n_r; u_t_face = u_t_r
1751 end if
1752 ! ADC blend NC face velocities with HLL scalar traces (valid fans; a fallback
1753 ! face already exports the pure HLL traces)
1754 if (riemann_hypo_adc) then
1755 u_n_face = u_n_hll_trace + phi*(u_n_face - u_n_hll_trace)
1756 u_t_face = u_t_hll_trace + phi*(u_t_face - u_t_hll_trace)
1757 end if
1758 end if
1759# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1760 if (ipass == 1) then
1761 if (dir_idx(1) == 1) then
1762 nc_iface_vel_rsx_vf(j, k, l, 1) = u_n_face
1763 nc_iface_vel_rsx_vf(j, k, l, 2) = u_t_face
1764 else
1765 nc_iface_vel_rsx_vf(j, k, l, 1) = u_t_face
1766 nc_iface_vel_rsx_vf(j, k, l, 2) = u_n_face
1767 end if
1768 end if
1769# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1770 if (ipass == 2) then
1771 if (dir_idx(1) == 1) then
1772 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_n_face
1773 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_t_face
1774 else
1775 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_t_face
1776 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_n_face
1777 end if
1778 end if
1779# 908 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1780 end if
1781
1782 ! Radial geometric source flux for cylindrical coordinates. Only genuinely conservative rows
1783 ! (masses, momenta, energy) carry a numerical geometric flux: their full radial flux IS the
1784 ! -H/r metric quantity. The volume-fraction and stress rows are zeroed: the augmented stress
1785 ! fluxes fold constitutive velocity terms that must not be divided by r; their complete
1786 ! cylindrical completion is the cell-local dual-pass source
1787 ! (s_compute_hypoelastic_rhs_axisym_geom_dual_pass).
1788# 959 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1789 end do
1790
1791 ! Dual-pass HLLD: all NC terms stay inside the Riemann flux (anchor-independent; written once)
1792 flux_src_rsx_vf(j, k, l, eqn_idx%adv%beg) = 0._wp
1793 end do
1794 end do
1795 end do
1796
1797# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1798#if defined(MFC_OpenACC)
1799# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1800!$acc end parallel loop
1801# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1802#elif defined(MFC_OpenMP)
1803# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1804
1805# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1806!$omp end target teams loop
1807# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1808#endif
1809 end if
1810# 172 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1811# 173 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1812# 174 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1813 if (norm_dir == 2) then
1814 ! Anchor-cell index pattern: the fused kernel reads both anchors (hat_L: face cell, hat_R: face cell + 1)
1815 ! directly from q_prim_vf; loop indices are physical, so the offset rides the stencil index.
1816# 178 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1817 ! The fused HLLD kernel privatizes ~150 scalars -- a private() list large enough that
1818 ! the single clause must be wrapped across continuation lines. The four fragments
1819 ! (_hlld_p1..p4) are ONLY for source readability; fypp concatenates them into one
1820 ! clause below. That wrapping is FOLD_DIRECTIVE's job -- its within-clause comma split
1821 ! exists for exactly this case -- not the fragments'.
1822# 184 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1823# 185 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1824# 186 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1825# 187 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1826 ! Wave-fan side table for the per-component F_hlld fold below: side name, the side's two zones,
1827 ! its starstar zone, and the outer/inner wave speeds. The L and R sides are mirror images.
1828# 190 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1829 ! Wave-fan component tables for the per-component fold below: (us, uss) expression pairs in
1830 ! F_hlld component order; uss = None means the inner (starstar) correction leaves the
1831 ! component unchanged (uss_c = us_c). '{S}' expands to the fan side (L/R).
1832# 207 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1833# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1834
1835# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1836
1837# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1838#if defined(MFC_OpenACC)
1839# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1840!$acc parallel loop collapse(3) gang vector default(present) private(i, j, k, l, ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, &
1841# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1842!$acc& gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, &
1843# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1844!$acc& tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, &
1845# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1846!$acc& tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, &
1847# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1848!$acc& alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, &
1849# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1850!$acc& tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, &
1851# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1852!$acc& E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, &
1853# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1854!$acc& alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, &
1855# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1856!$acc& sensor_ptot, sensor_vt, sensor_tnt, sensor_combined, phi, alpha_L_sum, alpha_R_sum)
1857# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1858#elif defined(MFC_OpenMP)
1859# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1860
1861# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1862
1863# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1864
1865# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1866!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(i, j, k, l, &
1867# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1868!$omp& ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, &
1869# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1870!$omp& pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, &
1871# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1872!$omp& ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, &
1873# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1874!$omp& tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, &
1875# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1876!$omp& u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, &
1877# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1878!$omp& tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, &
1879# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1880!$omp& tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, &
1881# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1882!$omp& blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, sensor_ptot, sensor_vt, sensor_tnt, &
1883# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1884!$omp& sensor_combined, phi, alpha_L_sum, alpha_R_sum)
1885# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1886#endif
1887 do l = is3%beg, is3%end
1888 do k = is1%beg, is1%end
1889 do j = is2%beg, is2%end
1890 ! Extract left/right primitive states
1891
1892 do i = 1, eqn_idx%cont%end
1893 alpha_rho_l(i) = ql_prim_rsx_vf(j, k, l, i)
1894 alpha_rho_r(i) = qr_prim_rsx_vf(j, k + 1, l, i)
1895 end do
1896
1897 ! Initialize the unused third velocity component in 2D
1898 vel%L = 0._wp
1899 vel%R = 0._wp
1900
1901 ! Load velocities in physical-coordinate order; map directional aliases below via dir_idx
1902 do i = 1, num_vels
1903 vel%L(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%cont%end + i)
1904 vel%R(i) = qr_prim_rsx_vf(j, k + 1, l, eqn_idx%cont%end + i)
1905 end do
1906
1907 vel_rms%L = vel%L(1)**2 + vel%L(2)**2 + vel%L(3)**2
1908 vel_rms%R = vel%R(1)**2 + vel%R(2)**2 + vel%R(3)**2
1909
1910 do i = 1, num_fluids
1911 alpha_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%E + i)
1912 alpha_r(i) = qr_prim_rsx_vf(j, k + 1, l, eqn_idx%E + i)
1913 end do
1914
1915 ! Clamp and renormalize volume fractions when mpp_lim is on (match HLL/HLLC)
1916 alpha_l_sum = 0._wp
1917 alpha_r_sum = 0._wp
1918 if (mpp_lim) then
1919 do i = 1, num_fluids
1920 alpha_rho_l(i) = max(0._wp, alpha_rho_l(i))
1921 alpha_l(i) = min(max(0._wp, alpha_l(i)), 1._wp)
1922 alpha_l_sum = alpha_l_sum + alpha_l(i)
1923 end do
1924 alpha_l = alpha_l/max(alpha_l_sum, sgm_eps)
1925
1926 do i = 1, num_fluids
1927 alpha_rho_r(i) = max(0._wp, alpha_rho_r(i))
1928 alpha_r(i) = min(max(0._wp, alpha_r(i)), 1._wp)
1929 alpha_r_sum = alpha_r_sum + alpha_r(i)
1930 end do
1931 alpha_r = alpha_r/max(alpha_r_sum, sgm_eps)
1932 end if
1933
1934 pres%L = ql_prim_rsx_vf(j, k, l, eqn_idx%E)
1935 pres%R = qr_prim_rsx_vf(j, k + 1, l, eqn_idx%E)
1936
1937 ! Hypoelasticity
1938
1939# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1940#if defined(MFC_OpenACC)
1941# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1942!$acc loop seq
1943# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1944#elif defined(MFC_OpenMP)
1945# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1946
1947# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
1948#endif
1949 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
1950 tau_e_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%stress%beg - 1 + i)
1951 tau_e_r(i) = qr_prim_rsx_vf(j, k + 1, l, eqn_idx%stress%beg - 1 + i)
1952 end do
1953
1954 u_t2_l = 0._wp; u_t2_r = 0._wp
1955 tau_nt2_l = 0._wp; tau_nt2_r = 0._wp
1956 tau_t2t2_l = 0._wp; tau_t2t2_r = 0._wp
1957 tau_t1t2_l = 0._wp; tau_t1t2_r = 0._wp
1958
1959 ! Map physical-basis arrays to directional aliases via stress_perm/dir_idx
1960 u_n_l = vel%L(dir_idx(1)); u_n_r = vel%R(dir_idx(1))
1961 tau_nn_l = tau_e_l(stress_perm(1)); tau_nn_r = tau_e_r(stress_perm(1))
1962 if (n == 0) then
1963 ncomp = 11
1964 else if (p == 0) then
1965 ncomp = 11
1966 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
1967 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
1968 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
1969 else
1970 ncomp = 14
1971 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
1972 u_t2_l = vel%L(dir_idx(3)); u_t2_r = vel%R(dir_idx(3))
1973 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
1974 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
1975 tau_nt2_l = tau_e_l(stress_perm(4)); tau_nt2_r = tau_e_r(stress_perm(4))
1976 tau_t1t2_l = tau_e_l(stress_perm(5)); tau_t1t2_r = tau_e_r(stress_perm(5))
1977 tau_t2t2_l = tau_e_l(stress_perm(6)); tau_t2t2_r = tau_e_r(stress_perm(6))
1978 end if
1979 if (cyl_coord) then
1980 tau_qq_l = tau_e_l(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
1981 tau_qq_r = tau_e_r(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
1982 else
1983 tau_qq_l = 0._wp; tau_qq_r = 0._wp
1984 end if
1985 ! Total pressure (replace the usual pressure to define SM)
1986 ptot_l = pres%L - tau_nn_l
1987 ptot_r = pres%R - tau_nn_r
1988
1989 ! Symmetrize total pressure when it differs only by floating-point roundoff. WENO reconstruction of a
1990 ! uniform field can produce slightly different L/R values at material interfaces due to different
1991 ! smoothness indicators. With stiff materials (G~1e9), even 1e-12 relative pTot asymmetry creates O(1)
1992 ! spurious stress through the HLLD star-state.
1993 if (abs(ptot_r - ptot_l) < 1e-12_wp*max(abs(ptot_l), abs(ptot_r), 1._wp)) then
1994 ptot_l = 5e-1_wp*(ptot_l + ptot_r)
1995 ptot_r = ptot_l
1996 end if
1997
1998 ! Sum properties of all fluid components
1999 rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp
2000 rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp
2001
2002# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2003#if defined(MFC_OpenACC)
2004# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2005!$acc loop seq
2006# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2007#elif defined(MFC_OpenMP)
2008# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2009
2010# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2011#endif
2012 do i = 1, num_fluids
2013 rho%L = rho%L + alpha_rho_l(i)
2014 gamma%L = gamma%L + alpha_l(i)*gammas(i)
2015 pi_inf%L = pi_inf%L + alpha_l(i)*pi_infs(i)
2016 qv%L = qv%L + alpha_rho_l(i)*qvs(i)
2017
2018 rho%R = rho%R + alpha_rho_r(i)
2019 gamma%R = gamma%R + alpha_r(i)*gammas(i)
2020 pi_inf%R = pi_inf%R + alpha_r(i)*pi_infs(i)
2021 qv%R = qv%R + alpha_rho_r(i)*qvs(i)
2022 end do
2023
2024 g_l = 0._wp; g_r = 0._wp
2025
2026# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2027#if defined(MFC_OpenACC)
2028# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2029!$acc loop seq
2030# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2031#elif defined(MFC_OpenMP)
2032# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2033
2034# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2035#endif
2036 do i = 1, num_fluids
2037 g_l = g_l + alpha_l(i)*gs_rs(i)
2038 g_r = g_r + alpha_r(i)*gs_rs(i)
2039 end do
2040
2041 e%L = gamma%L*pres%L + pi_inf%L + 5e-1_wp*rho%L*vel_rms%L + qv%L
2042 e%R = gamma%R*pres%R + pi_inf%R + 5e-1_wp*rho%R*vel_rms%R + qv%R
2043
2044 ! Freeze the thermal/kinetic enthalpy used by the EOS sound-speed call before
2045 ! adding hypoelastic strain energy to the conservative total energy.
2046 h%L = (e%L + pres%L)/rho%L
2047 h%R = (e%R + pres%R)/rho%R
2048
2049
2050# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2051#if defined(MFC_OpenACC)
2052# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2053!$acc loop seq
2054# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2055#elif defined(MFC_OpenMP)
2056# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2057
2058# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2059#endif
2060 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
2061 if (g_l > verysmall) then
2062# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2063 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
2064# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2065 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
2066# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2067 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
2068# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2069 end if
2070# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2071 end if
2072# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2073 if (g_r > verysmall) then
2074# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2075 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
2076# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2077 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
2078# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2079 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
2080# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2081 end if
2082# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2083 end if
2084# 356 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2085 end do
2086
2087 ! Compute Riemann states
2088
2089 call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, h%L, alpha_l, vel_rms%L, 0._wp, c%L, &
2090 & qv%L)
2091 call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, h%R, alpha_r, vel_rms%R, 0._wp, c%R, &
2092 & qv%R)
2093
2094 s_l = min(u_n_l - sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)), &
2095 & u_n_r - sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)))
2096 s_r = max(u_n_r + sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)), &
2097 & u_n_l + sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)))
2098
2099 if (p > 0 .and. .not. cyl_coord) then
2100 ! 3D Cartesian: 14-state compact basis
2101 u_l(1) = alpha_rho_l(1); u_r(1) = alpha_rho_r(1)
2102 u_l(2) = alpha_rho_l(2); u_r(2) = alpha_rho_r(2)
2103 u_l(3) = rho%L*u_n_l; u_r(3) = rho%R*u_n_r
2104 u_l(4) = rho%L*u_t_l; u_r(4) = rho%R*u_t_r
2105 u_l(5) = rho%L*u_t2_l; u_r(5) = rho%R*u_t2_r
2106 u_l(6) = e%L; u_r(6) = e%R
2107 u_l(7) = alpha_l(1); u_r(7) = alpha_r(1)
2108 u_l(8) = alpha_l(2); u_r(8) = alpha_r(2)
2109 u_l(9) = rho%L*tau_nn_l; u_r(9) = rho%R*tau_nn_r
2110 u_l(10) = rho%L*tau_nt_l; u_r(10) = rho%R*tau_nt_r
2111 u_l(11) = rho%L*tau_nt2_l; u_r(11) = rho%R*tau_nt2_r
2112 u_l(12) = rho%L*tau_tt_l; u_r(12) = rho%R*tau_tt_r
2113 u_l(13) = rho%L*tau_t2t2_l; u_r(13) = rho%R*tau_t2t2_r
2114 u_l(14) = rho%L*tau_t1t2_l; u_r(14) = rho%R*tau_t1t2_r
2115
2116 f_l(1) = u_l(1)*u_n_l; f_r(1) = u_r(1)*u_n_r
2117 f_l(2) = u_l(2)*u_n_l; f_r(2) = u_r(2)*u_n_r
2118 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
2119 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
2120 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
2121 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
2122 f_l(5) = rho%L*u_n_l*u_t2_l - tau_nt2_l
2123 f_r(5) = rho%R*u_n_r*u_t2_r - tau_nt2_r
2124 f_l(6) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l - u_t2_l*tau_nt2_l
2125 f_r(6) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r - u_t2_r*tau_nt2_r
2126 ! Rows 7-14 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
2127 ! inside the per-anchor pass loop below.
2128 else
2129 ! 2D/axisym: 11-state compact basis (unchanged)
2130 u_l(1) = alpha_rho_l(1)
2131 u_l(2) = alpha_rho_l(2)
2132 u_l(3) = rho%L*u_n_l
2133 u_l(4) = rho%L*u_t_l
2134 u_l(5) = e%L
2135 u_l(6) = alpha_l(1)
2136 u_l(7) = alpha_l(2)
2137 u_l(8) = rho%L*tau_nn_l
2138 u_l(9) = rho%L*tau_nt_l
2139 u_l(10) = rho%L*tau_tt_l
2140 u_l(11) = rho%L*tau_qq_l
2141
2142 u_r(1) = alpha_rho_r(1)
2143 u_r(2) = alpha_rho_r(2)
2144 u_r(3) = rho%R*u_n_r
2145 u_r(4) = rho%R*u_t_r
2146 u_r(5) = e%R
2147 u_r(6) = alpha_r(1)
2148 u_r(7) = alpha_r(2)
2149 u_r(8) = rho%R*tau_nn_r
2150 u_r(9) = rho%R*tau_nt_r
2151 u_r(10) = rho%R*tau_tt_r
2152 u_r(11) = rho%R*tau_qq_r
2153
2154 f_l(1) = u_l(1)*u_n_l
2155 f_l(2) = u_l(2)*u_n_l
2156 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
2157 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
2158 f_l(5) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l
2159
2160 f_r(1) = u_r(1)*u_n_r
2161 f_r(2) = u_r(2)*u_n_r
2162 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
2163 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
2164 f_r(5) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r
2165 ! Rows 6-11 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
2166 ! inside the per-anchor pass loop below.
2167 end if
2168
2169 a_l = rho%L*(s_l - u_n_l)
2170 a_r = rho%R*(s_r - u_n_r)
2171 denoma = (a_r - a_l)
2172
2173 s_m = ((ptot_r - ptot_l) + a_l*u_n_l - a_r*u_n_r)/(a_l - a_r + verysmall)
2174
2175 ! Degenerate wave structure: denom ~ 0 or S_M not in [S_L,S_R]. The test is anchor-independent, so both
2176 ! anchored solves below take the same branch.
2177 degenerate = (abs(denoma) < verysmall .or. .not. (s_l - verysmall <= s_m .and. s_m <= s_r + verysmall))
2178
2179 if (.not. degenerate) then
2180 ! Anchor-independent pieces of the star region (the anchor state enters only the volume-fraction and
2181 ! stress star states)
2182 ptot_star = ptot_l + a_l*(s_m - u_n_l)
2183
2184 ! Signed floor (HLLC-style, see m_riemann_solver_hllc.fpp) on the wave-fan denominators: guards the
2185 ! degenerate S_M -> S_L / S_M -> S_R limit, sign-preserving, and a no-op away from it (|denom| >>
2186 ! verysmall)
2187 rhol_star = rho%L*(s_l - u_n_l)/min(s_l - s_m, -verysmall)
2188 rhor_star = rho%R*(s_r - u_n_r)/max(s_r - s_m, verysmall)
2189 fac_l = (s_l - u_n_l)/min(s_l - s_m, -verysmall)
2190 fac_r = (s_r - u_n_r)/max(s_r - s_m, verysmall)
2191
2192 e_l_star = (e%L*(u_n_l - s_l) + u_n_l*ptot_l - s_m*ptot_star)/max(s_m - s_l, verysmall)
2193 e_r_star = (e%R*(u_n_r - s_r) + u_n_r*ptot_r - s_m*ptot_star)/min(s_m - s_r, -verysmall)
2194
2195 if (riemann_hypo_adc) then
2196 ! ADC sensors depend only on the L/R face states: computed once, shared by both anchored solves
2197 sigma_l = ptot_l
2198 sigma_r = ptot_r
2199 dsigma = sigma_r - sigma_l
2200 sigma_ref = max(max(abs(sigma_l), abs(sigma_r)), verysmall)
2201
2202 a_l_ref = sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L))
2203 a_r_ref = sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R))
2204 a_ref = max(max(a_l_ref, a_r_ref), verysmall)
2205
2206 du_t = u_t_r - u_t_l
2207 dtau_nt = tau_nt_r - tau_nt_l
2208 du_t2 = u_t2_r - u_t2_l
2209 dtau_nt2 = tau_nt2_r - tau_nt2_l
2210
2211 sensor_ptot = (dsigma*dsigma)/((adc_kappa*sigma_ref)**2 + verysmall)
2212 sensor_vt = (du_t*du_t + du_t2*du_t2)/((adc_kappa*a_ref)**2 + verysmall)
2213 sensor_tnt = (dtau_nt*dtau_nt + dtau_nt2*dtau_nt2)/((adc_kappa*sigma_ref)**2 + verysmall)
2214
2215 sensor_combined = sensor_ptot + sensor_tnt + sensor_vt
2216
2217 phi = exp(-(sensor_combined**adc_power))
2218 end if
2219 end if
2220
2221 ! Fused dual-pass: both anchored solves share everything above. The anchor (hat) state and everything it
2222 ! touches is evaluated per pass: pass 1 anchors on cell j (hat_L) and writes the flux_rs* set; pass 2
2223 ! anchors on cell j+1 (hat_R) and writes the flux_hatR_rs* set.
2224
2225# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2226#if defined(MFC_OpenACC)
2227# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2228!$acc loop seq
2229# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2230#elif defined(MFC_OpenMP)
2231# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2232
2233# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2234#endif
2235 do ipass = 1, 2
2236 do i = 1, eqn_idx%cont%end
2237 alpha_rho_hat(i) = q_prim_vf(i)%sf(j, k + ipass - 1, l)
2238 end do
2239 do i = 1, num_fluids
2240 alpha_hat(i) = q_prim_vf(eqn_idx%E + i)%sf(j, k + ipass - 1, l)
2241 end do
2242
2243# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2244#if defined(MFC_OpenACC)
2245# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2246!$acc loop seq
2247# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2248#elif defined(MFC_OpenMP)
2249# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2250
2251# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2252#endif
2253 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
2254 tau_e_hat(i) = q_prim_vf(eqn_idx%stress%beg - 1 + i)%sf(j, k + ipass - 1, l)
2255 end do
2256
2257 ! Anchor-state directional aliases (mirrors the L/R alias block above)
2258 tau_nt2_hat = 0._wp; tau_t2t2_hat = 0._wp; tau_t1t2_hat = 0._wp
2259 tau_nn_hat = tau_e_hat(stress_perm(1))
2260 if (n > 0) then
2261 tau_nt_hat = tau_e_hat(stress_perm(2))
2262 tau_tt_hat = tau_e_hat(stress_perm(3))
2263 if (p > 0) then
2264 tau_nt2_hat = tau_e_hat(stress_perm(4))
2265 tau_t1t2_hat = tau_e_hat(stress_perm(5))
2266 tau_t2t2_hat = tau_e_hat(stress_perm(6))
2267 end if
2268 end if
2269 if (cyl_coord) then
2270 tau_qq_hat = tau_e_hat(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
2271 else
2272 tau_qq_hat = 0._wp
2273 end if
2274
2275 rho_hat = 0._wp
2276
2277# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2278#if defined(MFC_OpenACC)
2279# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2280!$acc loop seq
2281# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2282#elif defined(MFC_OpenMP)
2283# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2284
2285# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2286#endif
2287 do i = 1, num_fluids
2288 rho_hat = rho_hat + alpha_rho_hat(i)
2289 end do
2290
2291 g_hat = 0._wp
2292
2293# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2294#if defined(MFC_OpenACC)
2295# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2296!$acc loop seq
2297# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2298#elif defined(MFC_OpenMP)
2299# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2300
2301# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2302#endif
2303 do i = 1, num_fluids
2304 g_hat = g_hat + alpha_hat(i)*gs_rs(i)
2305 end do
2306
2307 ! Two-component 2D only (enforced by checker restrictions)
2308 k_hat = 0._wp
2309 if (alt_soundspeed) then
2310 pres_hat = q_prim_vf(eqn_idx%E)%sf(j, k + ipass - 1, l)
2311 blkmod1_hat = ((gammas(1) + 1._wp)*pres_hat + pi_infs(1))/gammas(1) + (4._wp/3._wp)*gs_rs(1)
2312 blkmod2_hat = ((gammas(2) + 1._wp)*pres_hat + pi_infs(2))/gammas(2) + (4._wp/3._wp)*gs_rs(2)
2313 k_hat = alpha_hat(1)*alpha_hat(2)*(blkmod2_hat - blkmod1_hat)/(alpha_hat(1)*blkmod2_hat &
2314 & + alpha_hat(2)*blkmod1_hat + verysmall)
2315 end if
2316 c_hat_1 = alpha_hat(1) + k_hat
2317 c_hat_2 = alpha_hat(2) - k_hat
2318
2319 if (p > 0 .and. .not. cyl_coord) then
2320 ! 3D Cartesian: anchor-dependent rows (7-14) of the 14-state flux
2321 f_l(7) = u_l(7)*u_n_l - c_hat_1*u_n_l
2322 f_r(7) = u_r(7)*u_n_r - c_hat_1*u_n_r
2323 f_l(8) = u_l(8)*u_n_l - c_hat_2*u_n_l
2324 f_r(8) = u_r(8)*u_n_r - c_hat_2*u_n_r
2325 f_l(9) = u_l(9)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
2326 f_r(9) = u_r(9)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
2327 f_l(10) = u_l(10)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
2328 f_r(10) = u_r(10)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
2329 f_l(11) = u_l(11)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t2_l
2330 f_r(11) = u_r(11)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t2_r
2331 f_l(12) = u_l(12)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
2332 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
2333 f_r(12) = u_r(12)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
2334 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
2335 f_l(13) = u_l(13)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_l &
2336 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_l
2337 f_r(13) = u_r(13)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_r &
2338 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_r
2339 f_l(14) = u_l(14)*u_n_l + rho_hat*tau_t1t2_hat*u_n_l - rho_hat*tau_nt2_hat*u_t_l &
2340 & - rho_hat*tau_nt_hat*u_t2_l
2341 f_r(14) = u_r(14)*u_n_r + rho_hat*tau_t1t2_hat*u_n_r - rho_hat*tau_nt2_hat*u_t_r &
2342 & - rho_hat*tau_nt_hat*u_t2_r
2343 else
2344 ! 2D/axisym: anchor-dependent rows (6-11) of the 11-state flux
2345 f_l(6) = u_l(6)*u_n_l - c_hat_1*u_n_l
2346 f_r(6) = u_r(6)*u_n_r - c_hat_1*u_n_r
2347 f_l(7) = u_l(7)*u_n_l - c_hat_2*u_n_l
2348 f_r(7) = u_r(7)*u_n_r - c_hat_2*u_n_r
2349 f_l(8) = u_l(8)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
2350 f_r(8) = u_r(8)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
2351 f_l(9) = u_l(9)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
2352 f_r(9) = u_r(9)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
2353 f_l(10) = u_l(10)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
2354 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
2355 f_r(10) = u_r(10)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
2356 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
2357 f_l(11) = u_l(11)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_l
2358 f_r(11) = u_r(11)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_r
2359 end if
2360
2361 ! The effective shear stiffness is anchor-dependent. Resolve its three numerical states before
2362 ! forming C_NC: positive keeps HLLD; zero to cancellation accuracy takes the finite HLLC limit;
2363 ! materially negative (loss of the assumed real shear subfan) rejects the whole anchored fan.
2364 ! The tolerance is relative only to the two terms being added, not to an acoustic/material scale.
2365 fan_fallback = degenerate
2366 shear_degenerate = .false.
2367 if (.not. fan_fallback) then
2368 g_eff = g_hat + tau_nn_hat
2369 g_eff_tol = g_eff_roundoff_factor*epsilon(1._wp)*(abs(g_hat) + abs(tau_nn_hat))
2370
2371 if (.not. (g_eff >= -g_eff_tol)) then
2372 ! Materially negative, or unordered (NaN): no real five-wave shear fan.
2373 fan_fallback = .true.
2374 else if (g_eff <= g_eff_tol) then
2375 shear_degenerate = .true.
2376 s_lstar = s_m
2377 s_rstar = s_m
2378 else
2379 c_nc = rho_hat*g_eff
2380 if (.not. (c_nc > 0._wp)) then
2381 ! Positive G_eff below the representable C_NC range is numerically degenerate;
2382 ! nonpositive/unordered rho_hat is invalid for the same construction.
2383 shear_degenerate = (rho_hat > 0._wp)
2384 fan_fallback = .not. shear_degenerate
2385 s_lstar = s_m
2386 s_rstar = s_m
2387 else
2388 sqrtc_nc = sqrt(c_nc)
2389 s_lstar = s_m - sqrtc_nc/rhol_star
2390 s_rstar = s_m + sqrtc_nc/rhor_star
2391 ! A speed-only clamp would break the corresponding Rankine--Hugoniot jump.
2392 fan_fallback = (s_lstar < s_l .or. s_rstar > s_r)
2393 end if
2394 end if
2395 end if
2396
2397 if (fan_fallback) then
2398 ! HLL (or one-sided) fallback for an invalid wave structure
2399 if (s_l < 0._wp .and. s_r > 0._wp) then
2400 do i = 1, ncomp
2401 f_hlld(i) = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
2402 end do
2403 else if (s_l >= 0._wp) then
2404 f_hlld(1:ncomp) = f_l(1:ncomp)
2405 else
2406 f_hlld(1:ncomp) = f_r(1:ncomp)
2407 end if
2408 ! Initialize star-state variables to safe values so no path reads uninitialized memory
2409 ! (a subsequent valid pass restores what it needs). Fallback face exports do not use
2410 ! them: they take the HLL/one-sided traces computed below.
2411 ptot_star = 5e-1_wp*(ptot_l + ptot_r)
2412 s_lstar = s_l
2413 s_rstar = s_r
2414 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
2415 tau_nn_l_star = tau_nn_l
2416 tau_nn_r_star = tau_nn_r
2417 tau_qq_l_star = tau_qq_l
2418 tau_qq_r_star = tau_qq_r
2419 else
2420 ! A preceding anchored pass may have taken the fallback and assigned a safe face value.
2421 ! Restore the anchor-independent HLLD contact pressure for this valid pass.
2422 ptot_star = ptot_l + a_l*(s_m - u_n_l)
2423
2424 if (shear_degenerate) then
2425 ! Degenerate shear impedance: collapse inner waves to HLLC
2426 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
2427 tau_nt_star = 5e-1_wp*(tau_nt_l + tau_nt_r)
2428 u_t2_star = 5e-1_wp*(u_t2_l + u_t2_r)
2429 tau_nt2_star = 5e-1_wp*(tau_nt2_l + tau_nt2_r)
2430 else
2431 u_t_star = 5e-1_wp*((tau_nt_r - tau_nt_l)/sqrtc_nc + (u_t_r + u_t_l))
2432 tau_nt_star = 5e-1_wp*((u_t_r - u_t_l)*sqrtc_nc + (tau_nt_r + tau_nt_l))
2433 u_t2_star = 5e-1_wp*((tau_nt2_r - tau_nt2_l)/sqrtc_nc + (u_t2_r + u_t2_l))
2434 tau_nt2_star = 5e-1_wp*((u_t2_r - u_t2_l)*sqrtc_nc + (tau_nt2_r + tau_nt2_l))
2435 end if
2436
2437 ! Outer-wave stress star states: one formula family over the components. ELC is
2438 ! the anchor-side elastic coefficient (deviatoric 4/3 vs 2/3 structure; t1t2
2439 ! carries no G term) and SGN = -1/+1 the jump sign of the component.
2440# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2441# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2442 tau_nn_l_star = tau_nn_l - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
2443# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2444 tau_nn_r_star = tau_nn_r - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
2445# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2446# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2447# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2448 tau_tt_l_star = tau_tt_l + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
2449# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2450 tau_tt_r_star = tau_tt_r + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
2451# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2452# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2453# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2454 tau_t2t2_l_star = tau_t2t2_l + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
2455# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2456 tau_t2t2_r_star = tau_t2t2_r + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
2457# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2458# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2459# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2460 tau_t1t2_l_star = tau_t1t2_l + (rho_hat*tau_t1t2_hat*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
2461# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2462 tau_t1t2_r_star = tau_t1t2_r + (rho_hat*tau_t1t2_hat*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
2463# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2464# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2465# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2466 tau_qq_l_star = tau_qq_l + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
2467# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2468 tau_qq_r_star = tau_qq_r + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
2469# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2470# 680 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2471
2472 if (shear_degenerate) then
2473 ! Degenerate: no inner wave correction
2474 tau_tt_l_starstar = tau_tt_l_star
2475 tau_tt_r_starstar = tau_tt_r_star
2476 tau_t2t2_l_starstar = tau_t2t2_l_star
2477 tau_t2t2_r_starstar = tau_t2t2_r_star
2478 tau_t1t2_l_starstar = tau_t1t2_l_star
2479 tau_t1t2_r_starstar = tau_t1t2_r_star
2480 e_l_starstar = e_l_star
2481 e_r_starstar = e_r_star
2482 else
2483 tau_tt_l_starstar = tau_tt_l_star + 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_l)
2484 tau_tt_r_starstar = tau_tt_r_star - 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_r)
2485 tau_t2t2_l_starstar = tau_t2t2_l_star + 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
2486 & - u_t2_l)
2487 tau_t2t2_r_starstar = tau_t2t2_r_star - 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
2488 & - u_t2_r)
2489 tau_t1t2_l_starstar = tau_t1t2_l_star + rho_hat*(tau_nt2_hat*(u_t_star - u_t_l) &
2490 & + tau_nt_hat*(u_t2_star - u_t2_l))/sqrtc_nc
2491 tau_t1t2_r_starstar = tau_t1t2_r_star - rho_hat*(tau_nt2_hat*(u_t_star - u_t_r) &
2492 & + tau_nt_hat*(u_t2_star - u_t2_r))/sqrtc_nc
2493 e_l_starstar = e_l_star + (rhol_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_l*tau_nt_l) &
2494 & + (u_t2_star*tau_nt2_star - u_t2_l*tau_nt2_l))
2495 e_r_starstar = e_r_star - (rhor_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_r*tau_nt_r) &
2496 & + (u_t2_star*tau_nt2_star - u_t2_r*tau_nt2_r))
2497 end if
2498
2499 alpha1_l_star = (alpha_l(1)*(s_l - u_n_l) - c_hat_1*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
2500 alpha1_r_star = (alpha_r(1)*(s_r - u_n_r) - c_hat_1*(s_m - u_n_r))/max(s_r - s_m, verysmall)
2501
2502 alpha2_l_star = (alpha_l(2)*(s_l - u_n_l) - c_hat_2*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
2503 alpha2_r_star = (alpha_r(2)*(s_r - u_n_r) - c_hat_2*(s_m - u_n_r))/max(s_r - s_m, verysmall)
2504
2505 ! HLLD flux, register-diet form: pick the wave-fan zone once (it is
2506 ! component-independent), then fold the selected side's star/starstar states into
2507 ! F_hlld one component at a time through the scalars us_c/uss_c (no fan arrays
2508 ! survive). The L and R sides are mirror images and the per-component statements
2509 ! share one shape, so the whole fold is emitted from one Fypp template driven by
2510 ! HLLD_FAN_SIDES and the HLLD_FAN_COMPS_3D/2D tables above. Per-component operation
2511 ! order matches the materialized form, so the flux is -O0 bit-identical. Do NOT
2512 ! re-expand into per-region temp arrays (or reorder the fold) without re-checking
2513 ! GPU register spill and the -O0 exactness gate.
2514
2515 zone = f_hlld_wave_zone(s_l, s_lstar, s_m, s_rstar, s_r)
2516
2517 if (zone == 0) then
2518 f_hlld(1:ncomp) = f_l(1:ncomp)
2519 else if (zone == 5) then
2520 f_hlld(1:ncomp) = f_r(1:ncomp)
2521# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2522 else if (zone == 1 .or. zone == 2) then
2523 ! L side of the fan: per component, us_c/uss_c are the selected side's
2524 ! star/starstar states (the old F_starL is folded into the first F_hlld
2525 ! statement; the starstar correction applies in zone 2 only, with the
2526 ! left-associative order of the materialized form preserved)
2527 if (p > 0 .and. .not. cyl_coord) then
2528# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2529 us_c = u_l(1)*fac_l
2530 uss_c = us_c
2531 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
2532 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
2533 & - us_c)
2534# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2535 us_c = u_l(2)*fac_l
2536 uss_c = us_c
2537 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
2538 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
2539 & - us_c)
2540# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2541 us_c = rhol_star*s_m
2542 uss_c = us_c
2543 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
2544 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
2545 & - us_c)
2546# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2547 us_c = rhol_star*u_t_l
2548 uss_c = rhol_star*u_t_star
2549 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
2550 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
2551 & - us_c)
2552# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2553 us_c = rhol_star*u_t2_l
2554 uss_c = rhol_star*u_t2_star
2555 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
2556 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
2557 & - us_c)
2558# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2559 us_c = e_l_star
2560 uss_c = e_l_starstar
2561 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
2562 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
2563 & - us_c)
2564# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2565 us_c = alpha1_l_star
2566 uss_c = us_c
2567 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
2568 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
2569 & - us_c)
2570# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2571 us_c = alpha2_l_star
2572 uss_c = us_c
2573 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
2574 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
2575 & - us_c)
2576# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2577 us_c = rhol_star*tau_nn_l_star
2578 uss_c = us_c
2579 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
2580 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
2581 & - us_c)
2582# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2583 us_c = rhol_star*tau_nt_l
2584 uss_c = rhol_star*tau_nt_star
2585 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
2586 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
2587 & - us_c)
2588# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2589 us_c = rhol_star*tau_nt2_l
2590 uss_c = rhol_star*tau_nt2_star
2591 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
2592 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
2593 & - us_c)
2594# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2595 us_c = rhol_star*tau_tt_l_star
2596 uss_c = rhol_star*tau_tt_l_starstar
2597 f_hlld(12) = f_l(12) + s_l*(us_c - u_l(12))
2598 if (zone == 2) f_hlld(12) = f_hlld(12) + s_lstar*(uss_c &
2599 & - us_c)
2600# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2601 us_c = rhol_star*tau_t2t2_l_star
2602 uss_c = rhol_star*tau_t2t2_l_starstar
2603 f_hlld(13) = f_l(13) + s_l*(us_c - u_l(13))
2604 if (zone == 2) f_hlld(13) = f_hlld(13) + s_lstar*(uss_c &
2605 & - us_c)
2606# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2607 us_c = rhol_star*tau_t1t2_l_star
2608 uss_c = rhol_star*tau_t1t2_l_starstar
2609 f_hlld(14) = f_l(14) + s_l*(us_c - u_l(14))
2610 if (zone == 2) f_hlld(14) = f_hlld(14) + s_lstar*(uss_c &
2611 & - us_c)
2612# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2613 else
2614# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2615 us_c = u_l(1)*fac_l
2616 uss_c = us_c
2617 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
2618 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
2619 & - us_c)
2620# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2621 us_c = u_l(2)*fac_l
2622 uss_c = us_c
2623 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
2624 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
2625 & - us_c)
2626# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2627 us_c = rhol_star*s_m
2628 uss_c = us_c
2629 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
2630 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
2631 & - us_c)
2632# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2633 us_c = rhol_star*u_t_l
2634 uss_c = rhol_star*u_t_star
2635 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
2636 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
2637 & - us_c)
2638# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2639 us_c = e_l_star
2640 uss_c = e_l_starstar
2641 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
2642 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
2643 & - us_c)
2644# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2645 us_c = alpha1_l_star
2646 uss_c = us_c
2647 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
2648 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
2649 & - us_c)
2650# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2651 us_c = alpha2_l_star
2652 uss_c = us_c
2653 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
2654 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
2655 & - us_c)
2656# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2657 us_c = rhol_star*tau_nn_l_star
2658 uss_c = us_c
2659 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
2660 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
2661 & - us_c)
2662# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2663 us_c = rhol_star*tau_nt_l
2664 uss_c = rhol_star*tau_nt_star
2665 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
2666 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
2667 & - us_c)
2668# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2669 us_c = rhol_star*tau_tt_l_star
2670 uss_c = rhol_star*tau_tt_l_starstar
2671 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
2672 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
2673 & - us_c)
2674# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2675 us_c = rhol_star*tau_qq_l_star
2676 uss_c = us_c
2677 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
2678 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
2679 & - us_c)
2680# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2681 end if
2682# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2683 else if (zone == 3 .or. zone == 4) then
2684 ! R side of the fan: per component, us_c/uss_c are the selected side's
2685 ! star/starstar states (the old F_starR is folded into the first F_hlld
2686 ! statement; the starstar correction applies in zone 3 only, with the
2687 ! left-associative order of the materialized form preserved)
2688 if (p > 0 .and. .not. cyl_coord) then
2689# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2690 us_c = u_r(1)*fac_r
2691 uss_c = us_c
2692 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
2693 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
2694 & - us_c)
2695# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2696 us_c = u_r(2)*fac_r
2697 uss_c = us_c
2698 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
2699 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
2700 & - us_c)
2701# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2702 us_c = rhor_star*s_m
2703 uss_c = us_c
2704 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
2705 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
2706 & - us_c)
2707# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2708 us_c = rhor_star*u_t_r
2709 uss_c = rhor_star*u_t_star
2710 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
2711 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
2712 & - us_c)
2713# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2714 us_c = rhor_star*u_t2_r
2715 uss_c = rhor_star*u_t2_star
2716 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
2717 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
2718 & - us_c)
2719# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2720 us_c = e_r_star
2721 uss_c = e_r_starstar
2722 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
2723 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
2724 & - us_c)
2725# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2726 us_c = alpha1_r_star
2727 uss_c = us_c
2728 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
2729 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
2730 & - us_c)
2731# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2732 us_c = alpha2_r_star
2733 uss_c = us_c
2734 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
2735 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
2736 & - us_c)
2737# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2738 us_c = rhor_star*tau_nn_r_star
2739 uss_c = us_c
2740 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
2741 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
2742 & - us_c)
2743# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2744 us_c = rhor_star*tau_nt_r
2745 uss_c = rhor_star*tau_nt_star
2746 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
2747 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
2748 & - us_c)
2749# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2750 us_c = rhor_star*tau_nt2_r
2751 uss_c = rhor_star*tau_nt2_star
2752 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
2753 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
2754 & - us_c)
2755# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2756 us_c = rhor_star*tau_tt_r_star
2757 uss_c = rhor_star*tau_tt_r_starstar
2758 f_hlld(12) = f_r(12) + s_r*(us_c - u_r(12))
2759 if (zone == 3) f_hlld(12) = f_hlld(12) + s_rstar*(uss_c &
2760 & - us_c)
2761# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2762 us_c = rhor_star*tau_t2t2_r_star
2763 uss_c = rhor_star*tau_t2t2_r_starstar
2764 f_hlld(13) = f_r(13) + s_r*(us_c - u_r(13))
2765 if (zone == 3) f_hlld(13) = f_hlld(13) + s_rstar*(uss_c &
2766 & - us_c)
2767# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2768 us_c = rhor_star*tau_t1t2_r_star
2769 uss_c = rhor_star*tau_t1t2_r_starstar
2770 f_hlld(14) = f_r(14) + s_r*(us_c - u_r(14))
2771 if (zone == 3) f_hlld(14) = f_hlld(14) + s_rstar*(uss_c &
2772 & - us_c)
2773# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2774 else
2775# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2776 us_c = u_r(1)*fac_r
2777 uss_c = us_c
2778 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
2779 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
2780 & - us_c)
2781# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2782 us_c = u_r(2)*fac_r
2783 uss_c = us_c
2784 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
2785 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
2786 & - us_c)
2787# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2788 us_c = rhor_star*s_m
2789 uss_c = us_c
2790 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
2791 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
2792 & - us_c)
2793# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2794 us_c = rhor_star*u_t_r
2795 uss_c = rhor_star*u_t_star
2796 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
2797 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
2798 & - us_c)
2799# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2800 us_c = e_r_star
2801 uss_c = e_r_starstar
2802 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
2803 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
2804 & - us_c)
2805# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2806 us_c = alpha1_r_star
2807 uss_c = us_c
2808 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
2809 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
2810 & - us_c)
2811# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2812 us_c = alpha2_r_star
2813 uss_c = us_c
2814 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
2815 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
2816 & - us_c)
2817# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2818 us_c = rhor_star*tau_nn_r_star
2819 uss_c = us_c
2820 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
2821 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
2822 & - us_c)
2823# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2824 us_c = rhor_star*tau_nt_r
2825 uss_c = rhor_star*tau_nt_star
2826 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
2827 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
2828 & - us_c)
2829# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2830 us_c = rhor_star*tau_tt_r_star
2831 uss_c = rhor_star*tau_tt_r_starstar
2832 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
2833 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
2834 & - us_c)
2835# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2836 us_c = rhor_star*tau_qq_r_star
2837 uss_c = us_c
2838 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
2839 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
2840 & - us_c)
2841# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2842 end if
2843# 754 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2844 end if
2845
2846 ! ADC blending (HLLD / HLL)
2847
2848 if (riemann_hypo_adc) then
2849 ! Register-diet form: the HLL flux enters per component as the scalar F_HLL_c
2850 ! instead of a materialized F_HLL array; outside the subsonic fan F_HLL equals
2851 ! F_hlld and the identity blend is kept explicitly so the arithmetic (including
2852 ! signed-zero behavior) matches the array form bit-for-bit.
2853 ! phi is anchor-independent: computed once in the shared section above
2854 if (s_l < 0._wp .and. s_r > 0._wp) then
2855 do i = 1, ncomp
2856 f_hll_c = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
2857 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
2858 end do
2859 else
2860 do i = 1, ncomp
2861 f_hll_c = f_hlld(i)
2862 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
2863 end do
2864 end if
2865 end if
2866 end if
2867
2868 ! HLL face traces for the axisymmetric completion: consumed by the ADC face-state blend on
2869 ! valid fans and by the face exports on fallback faces (whose conservative flux is the
2870 ! matching HLL/one-sided flux). Rows 8/11 carry the pass's anchored folds, so the traces
2871 ! are anchor-dependent, like the ADC reference they generalize.
2872 if (cyl_coord .and. (riemann_hypo_adc .or. fan_fallback)) then
2873 if (0._wp <= s_l) then
2874 u_n_hll_trace = u_n_l; u_t_hll_trace = u_t_l
2875 p_face_hll = pres%L; tau_qq_face_hll = tau_qq_l
2876 else if (s_r <= 0._wp) then
2877 u_n_hll_trace = u_n_r; u_t_hll_trace = u_t_r
2878 p_face_hll = pres%R; tau_qq_face_hll = tau_qq_r
2879 else
2880 u_n_hll_trace = (s_r*u_n_l - s_l*u_n_r)/(s_r - s_l + verysmall)
2881 u_t_hll_trace = (s_r*u_t_l - s_l*u_t_r)/(s_r - s_l + verysmall)
2882 ! Only HLL-state components 1, 2, 3, 8 and 11 feed the axisym trace
2883 u_hll_c = (s_r*u_r(1) - s_l*u_l(1) - (f_r(1) - f_l(1)))/(s_r - s_l + verysmall)
2884 rho_hll = u_hll_c
2885 u_hll_c = (s_r*u_r(2) - s_l*u_l(2) - (f_r(2) - f_l(2)))/(s_r - s_l + verysmall)
2886 rho_hll = rho_hll + u_hll_c
2887 u_hll_c = (s_r*u_r(3) - s_l*u_l(3) - (f_r(3) - f_l(3)))/(s_r - s_l + verysmall)
2888 u_n_hll_cons = u_hll_c/(rho_hll + verysmall)
2889 u_hll_c = (s_r*u_r(8) - s_l*u_l(8) - (f_r(8) - f_l(8)))/(s_r - s_l + verysmall)
2890 tau_nn_hll = u_hll_c/(rho_hll + verysmall)
2891 u_hll_c = (s_r*u_r(11) - s_l*u_l(11) - (f_r(11) - f_l(11)))/(s_r - s_l + verysmall)
2892 tau_qq_face_hll = u_hll_c/(rho_hll + verysmall)
2893 ! This branch implies S_L < 0 < S_R, so component 3 of F_HLL is the interior HLL flux
2894 f_hll_c = (s_r*f_l(3) - s_l*f_r(3) + s_l*s_r*(u_r(3) - u_l(3)))/(s_r - s_l + verysmall)
2895 p_face_hll = f_hll_c - rho_hll*u_n_hll_cons*u_n_hll_cons + tau_nn_hll
2896 end if
2897 end if
2898
2899 ! Reorder F_HLLD for output: pass 1 (hat_L) -> flux_rs*, pass 2 (hat_R) -> flux_hatR_rs*
2900# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2901 if (ipass == 1) then
2902 if (p > 0 .and. .not. cyl_coord) then
2903 ! 3D Cartesian: 14-state -> physical indices
2904 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
2905 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
2906 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
2907 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
2908 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
2909 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
2910 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
2911 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
2912 ! Map local stress to physical stress indices
2913 if (dir_idx(1) == 1) then
2914 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
2915 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
2916 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
2917 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
2918 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
2919 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
2920 else if (dir_idx(1) == 2) then
2921 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
2922 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
2923 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
2924 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
2925 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
2926 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
2927 else
2928 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
2929 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
2930 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
2931 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
2932 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
2933 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
2934 end if
2935 else
2936 ! 2D/axisym: 11-state (unchanged)
2937 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
2938 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
2939 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
2940 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
2941 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
2942 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
2943 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
2944 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
2945 if (dir_idx(1) == 1) then
2946 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
2947 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
2948 else
2949 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
2950 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
2951 end if
2952 if (cyl_coord) then
2953 flux_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
2954 end if
2955 end if
2956 end if
2957# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
2958 if (ipass == 2) then
2959 if (p > 0 .and. .not. cyl_coord) then
2960 ! 3D Cartesian: 14-state -> physical indices
2961 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
2962 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
2963 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
2964 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
2965 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
2966 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
2967 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
2968 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
2969 ! Map local stress to physical stress indices
2970 if (dir_idx(1) == 1) then
2971 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
2972 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
2973 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
2974 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
2975 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
2976 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
2977 else if (dir_idx(1) == 2) then
2978 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
2979 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
2980 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
2981 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
2982 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
2983 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
2984 else
2985 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
2986 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
2987 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
2988 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
2989 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
2990 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
2991 end if
2992 else
2993 ! 2D/axisym: 11-state (unchanged)
2994 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
2995 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
2996 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
2997 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
2998 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
2999 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
3000 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
3001 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
3002 if (dir_idx(1) == 1) then
3003 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
3004 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
3005 else
3006 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
3007 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
3008 end if
3009 if (cyl_coord) then
3010 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
3011 end if
3012 end if
3013 end if
3014# 868 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3015
3016 ! Export face velocities for axisym hypo source terms
3017 if (grid_geometry == 2) then
3018 if (fan_fallback) then
3019 ! Fallback face: the conservative flux is the HLL/one-sided flux, so export the
3020 ! matching HLL/one-sided traces, not the rejected fan's contact speed/star states
3021 u_n_face = u_n_hll_trace; u_t_face = u_t_hll_trace
3022 else
3023 ! Upwind by wave-fan wedge: the inner zones ride the contact (u_n = S_M) and the
3024 ! tangential state switches L -> star -> R across the shear waves (zones 2 and 3
3025 ! share the tangential star state)
3026 if (zone == 0) then
3027 u_n_face = u_n_l; u_t_face = u_t_l
3028 else if (zone == 1) then
3029 u_n_face = s_m; u_t_face = u_t_l
3030 else if (zone <= 3) then
3031 u_n_face = s_m; u_t_face = u_t_star
3032 else if (zone == 4) then
3033 u_n_face = s_m; u_t_face = u_t_r
3034 else
3035 u_n_face = u_n_r; u_t_face = u_t_r
3036 end if
3037 ! ADC blend NC face velocities with HLL scalar traces (valid fans; a fallback
3038 ! face already exports the pure HLL traces)
3039 if (riemann_hypo_adc) then
3040 u_n_face = u_n_hll_trace + phi*(u_n_face - u_n_hll_trace)
3041 u_t_face = u_t_hll_trace + phi*(u_t_face - u_t_hll_trace)
3042 end if
3043 end if
3044# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3045 if (ipass == 1) then
3046 if (dir_idx(1) == 1) then
3047 nc_iface_vel_rsx_vf(j, k, l, 1) = u_n_face
3048 nc_iface_vel_rsx_vf(j, k, l, 2) = u_t_face
3049 else
3050 nc_iface_vel_rsx_vf(j, k, l, 1) = u_t_face
3051 nc_iface_vel_rsx_vf(j, k, l, 2) = u_n_face
3052 end if
3053 end if
3054# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3055 if (ipass == 2) then
3056 if (dir_idx(1) == 1) then
3057 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_n_face
3058 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_t_face
3059 else
3060 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_t_face
3061 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_n_face
3062 end if
3063 end if
3064# 908 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3065 end if
3066
3067 ! Radial geometric source flux for cylindrical coordinates. Only genuinely conservative rows
3068 ! (masses, momenta, energy) carry a numerical geometric flux: their full radial flux IS the
3069 ! -H/r metric quantity. The volume-fraction and stress rows are zeroed: the augmented stress
3070 ! fluxes fold constitutive velocity terms that must not be divided by r; their complete
3071 ! cylindrical completion is the cell-local dual-pass source
3072 ! (s_compute_hypoelastic_rhs_axisym_geom_dual_pass).
3073# 917 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3074 if (cyl_coord) then
3075# 920 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3076 if (ipass == 1) then
3077
3078# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3079#if defined(MFC_OpenACC)
3080# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3081!$acc loop seq
3082# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3083#elif defined(MFC_OpenMP)
3084# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3085
3086# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3087#endif
3088 do i = 1, eqn_idx%E
3089 flux_gsrc_rsx_vf(j, k, l, i) = flux_rsx_vf(j, k, l, i)
3090 end do
3091 if (fan_fallback) then
3092 ! Fallback face: HLL/one-sided face state, consistent with the
3093 ! selected conservative flux
3094 p_face = p_face_hll; tau_qq_face = tau_qq_face_hll
3095 else
3096 ! Pure HLLD face state, upwinded by wave-fan wedge (left/right of the contact)
3097 if (zone == 0) then
3098 p_face = pres%L; tau_qq_face = tau_qq_l
3099 else if (zone <= 2) then
3100 p_face = ptot_star + tau_nn_l_star; tau_qq_face = tau_qq_l_star
3101 else if (zone <= 4) then
3102 p_face = ptot_star + tau_nn_r_star; tau_qq_face = tau_qq_r_star
3103 else
3104 p_face = pres%R; tau_qq_face = tau_qq_r
3105 end if
3106 ! ADC blend face state (valid fans; a fallback face already uses the
3107 ! pure HLL state)
3108 if (riemann_hypo_adc) then
3109 p_face = p_face_hll + phi*(p_face - p_face_hll)
3110 tau_qq_face = tau_qq_face_hll + phi*(tau_qq_face - tau_qq_face_hll)
3111 end if
3112 end if
3113 flux_gsrc_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = flux_rsx_vf(j, k, l, &
3114 & eqn_idx%cont%end + dir_idx(1)) - p_face + tau_qq_face
3115 ! Every HLLD-legal configuration places only the volume-fraction and stress rows
3116 ! above eqn_idx%E (see s_check_inputs_hypo_branch)
3117
3118# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3119#if defined(MFC_OpenACC)
3120# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3121!$acc loop seq
3122# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3123#elif defined(MFC_OpenMP)
3124# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3125
3126# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3127#endif
3128 do i = eqn_idx%adv%beg, sys_size
3129 flux_gsrc_rsx_vf(j, k, l, i) = 0._wp
3130 end do
3131 end if
3132# 920 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3133 if (ipass == 2) then
3134
3135# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3136#if defined(MFC_OpenACC)
3137# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3138!$acc loop seq
3139# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3140#elif defined(MFC_OpenMP)
3141# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3142
3143# 921 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3144#endif
3145 do i = 1, eqn_idx%E
3146 flux_gsrc_hatr_rsx_vf(j, k, l, i) = flux_hatr_rsx_vf(j, k, l, i)
3147 end do
3148 if (fan_fallback) then
3149 ! Fallback face: HLL/one-sided face state, consistent with the
3150 ! selected conservative flux
3151 p_face = p_face_hll; tau_qq_face = tau_qq_face_hll
3152 else
3153 ! Pure HLLD face state, upwinded by wave-fan wedge (left/right of the contact)
3154 if (zone == 0) then
3155 p_face = pres%L; tau_qq_face = tau_qq_l
3156 else if (zone <= 2) then
3157 p_face = ptot_star + tau_nn_l_star; tau_qq_face = tau_qq_l_star
3158 else if (zone <= 4) then
3159 p_face = ptot_star + tau_nn_r_star; tau_qq_face = tau_qq_r_star
3160 else
3161 p_face = pres%R; tau_qq_face = tau_qq_r
3162 end if
3163 ! ADC blend face state (valid fans; a fallback face already uses the
3164 ! pure HLL state)
3165 if (riemann_hypo_adc) then
3166 p_face = p_face_hll + phi*(p_face - p_face_hll)
3167 tau_qq_face = tau_qq_face_hll + phi*(tau_qq_face - tau_qq_face_hll)
3168 end if
3169 end if
3170 flux_gsrc_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = flux_hatr_rsx_vf(j, k, l, &
3171 & eqn_idx%cont%end + dir_idx(1)) - p_face + tau_qq_face
3172 ! Every HLLD-legal configuration places only the volume-fraction and stress rows
3173 ! above eqn_idx%E (see s_check_inputs_hypo_branch)
3174
3175# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3176#if defined(MFC_OpenACC)
3177# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3178!$acc loop seq
3179# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3180#elif defined(MFC_OpenMP)
3181# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3182
3183# 951 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3184#endif
3185 do i = eqn_idx%adv%beg, sys_size
3186 flux_gsrc_hatr_rsx_vf(j, k, l, i) = 0._wp
3187 end do
3188 end if
3189# 957 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3190 end if
3191# 959 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3192 end do
3193
3194 ! Dual-pass HLLD: all NC terms stay inside the Riemann flux (anchor-independent; written once)
3195 flux_src_rsx_vf(j, k, l, eqn_idx%adv%beg) = 0._wp
3196 end do
3197 end do
3198 end do
3199
3200# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3201#if defined(MFC_OpenACC)
3202# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3203!$acc end parallel loop
3204# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3205#elif defined(MFC_OpenMP)
3206# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3207
3208# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3209!$omp end target teams loop
3210# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3211#endif
3212 end if
3213# 172 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3214# 173 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3215# 174 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3216 if (norm_dir == 3) then
3217 ! Anchor-cell index pattern: the fused kernel reads both anchors (hat_L: face cell, hat_R: face cell + 1)
3218 ! directly from q_prim_vf; loop indices are physical, so the offset rides the stencil index.
3219# 178 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3220 ! The fused HLLD kernel privatizes ~150 scalars -- a private() list large enough that
3221 ! the single clause must be wrapped across continuation lines. The four fragments
3222 ! (_hlld_p1..p4) are ONLY for source readability; fypp concatenates them into one
3223 ! clause below. That wrapping is FOLD_DIRECTIVE's job -- its within-clause comma split
3224 ! exists for exactly this case -- not the fragments'.
3225# 184 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3226# 185 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3227# 186 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3228# 187 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3229 ! Wave-fan side table for the per-component F_hlld fold below: side name, the side's two zones,
3230 ! its starstar zone, and the outer/inner wave speeds. The L and R sides are mirror images.
3231# 190 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3232 ! Wave-fan component tables for the per-component fold below: (us, uss) expression pairs in
3233 ! F_hlld component order; uss = None means the inner (starstar) correction leaves the
3234 ! component unchanged (uss_c = us_c). '{S}' expands to the fan side (L/R).
3235# 207 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3236# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3237
3238# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3239
3240# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3241#if defined(MFC_OpenACC)
3242# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3243!$acc parallel loop collapse(3) gang vector default(present) private(i, j, k, l, ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, &
3244# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3245!$acc& gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, &
3246# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3247!$acc& tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, &
3248# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3249!$acc& tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, &
3250# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3251!$acc& alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, &
3252# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3253!$acc& tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, &
3254# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3255!$acc& E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, &
3256# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3257!$acc& alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, &
3258# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3259!$acc& sensor_ptot, sensor_vt, sensor_tnt, sensor_combined, phi, alpha_L_sum, alpha_R_sum)
3260# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3261#elif defined(MFC_OpenMP)
3262# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3263
3264# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3265
3266# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3267
3268# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3269!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(3) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer) private(i, j, k, l, &
3270# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3271!$omp& ipass, degenerate, shear_degenerate, fan_fallback, alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, H, gamma, pi_inf, qv, vel_rms, c, S_L, S_R, s_M, S_Lstar, S_Rstar, pTot_L, &
3272# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3273!$omp& pTot_R, rhoL_star, rhoR_star, U_L, U_R, F_L, F_R, F_hlld, us_c, uss_c, zone, F_HLL_c, U_HLL_c, rho_HLL, u_n_HLL_cons, tau_nn_HLL, u_n_HLL_trace, u_t_HLL_trace, p_face_HLL, tau_qq_face_HLL, &
3274# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3275!$omp& ncomp, G_eff, G_eff_tol, C_NC, sqrtC_NC, A_L, A_R, denomA, fac_L, fac_R, u_n_L, u_t_L, u_n_R, u_t_R, u_t2_L, u_t2_R, tau_nn_L, tau_nt_L, tau_tt_L, tau_nn_R, tau_nt_R, tau_tt_R, tau_nt2_L, &
3276# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3277!$omp& tau_nt2_R, tau_t2t2_L, tau_t2t2_R, tau_t1t2_L, tau_t1t2_R, tau_qq_L, tau_qq_R, G_L, G_R, tau_e_L, tau_e_R, alpha1_L_star, alpha1_R_star, alpha2_L_star, alpha2_R_star, u_t_star, tau_nt_star, &
3278# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3279!$omp& u_t2_star, tau_nt2_star, tau_nn_L_star, tau_nn_R_star, tau_tt_L_star, tau_tt_R_star, tau_tt_L_starstar, tau_tt_R_starstar, tau_t2t2_L_star, tau_t2t2_R_star, tau_t2t2_L_starstar, &
3280# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3281!$omp& tau_t2t2_R_starstar, tau_t1t2_L_star, tau_t1t2_R_star, tau_t1t2_L_starstar, tau_t1t2_R_starstar, tau_qq_L_star, tau_qq_R_star, pTot_star, E_L_star, E_R_star, E_L_starstar, E_R_starstar, p_face, &
3282# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3283!$omp& tau_qq_face, u_n_face, u_t_face, G_hat, rho_hat, tau_nn_hat, tau_nt_hat, tau_tt_hat, tau_qq_hat, tau_nt2_hat, tau_t2t2_hat, tau_t1t2_hat, alpha_hat, alpha_rho_hat, tau_e_hat, pres_hat, &
3284# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3285!$omp& blkmod1_hat, blkmod2_hat, K_hat, C_hat_1, C_hat_2, Sigma_L, Sigma_R, dSigma, Sigma_ref, a_L_ref, a_R_ref, a_ref, du_t, dtau_nt, du_t2, dtau_nt2, sensor_ptot, sensor_vt, sensor_tnt, &
3286# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3287!$omp& sensor_combined, phi, alpha_L_sum, alpha_R_sum)
3288# 218 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3289#endif
3290 do l = is1%beg, is1%end
3291 do k = is2%beg, is2%end
3292 do j = is3%beg, is3%end
3293 ! Extract left/right primitive states
3294
3295 do i = 1, eqn_idx%cont%end
3296 alpha_rho_l(i) = ql_prim_rsx_vf(j, k, l, i)
3297 alpha_rho_r(i) = qr_prim_rsx_vf(j, k, l + 1, i)
3298 end do
3299
3300 ! Initialize the unused third velocity component in 2D
3301 vel%L = 0._wp
3302 vel%R = 0._wp
3303
3304 ! Load velocities in physical-coordinate order; map directional aliases below via dir_idx
3305 do i = 1, num_vels
3306 vel%L(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%cont%end + i)
3307 vel%R(i) = qr_prim_rsx_vf(j, k, l + 1, eqn_idx%cont%end + i)
3308 end do
3309
3310 vel_rms%L = vel%L(1)**2 + vel%L(2)**2 + vel%L(3)**2
3311 vel_rms%R = vel%R(1)**2 + vel%R(2)**2 + vel%R(3)**2
3312
3313 do i = 1, num_fluids
3314 alpha_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%E + i)
3315 alpha_r(i) = qr_prim_rsx_vf(j, k, l + 1, eqn_idx%E + i)
3316 end do
3317
3318 ! Clamp and renormalize volume fractions when mpp_lim is on (match HLL/HLLC)
3319 alpha_l_sum = 0._wp
3320 alpha_r_sum = 0._wp
3321 if (mpp_lim) then
3322 do i = 1, num_fluids
3323 alpha_rho_l(i) = max(0._wp, alpha_rho_l(i))
3324 alpha_l(i) = min(max(0._wp, alpha_l(i)), 1._wp)
3325 alpha_l_sum = alpha_l_sum + alpha_l(i)
3326 end do
3327 alpha_l = alpha_l/max(alpha_l_sum, sgm_eps)
3328
3329 do i = 1, num_fluids
3330 alpha_rho_r(i) = max(0._wp, alpha_rho_r(i))
3331 alpha_r(i) = min(max(0._wp, alpha_r(i)), 1._wp)
3332 alpha_r_sum = alpha_r_sum + alpha_r(i)
3333 end do
3334 alpha_r = alpha_r/max(alpha_r_sum, sgm_eps)
3335 end if
3336
3337 pres%L = ql_prim_rsx_vf(j, k, l, eqn_idx%E)
3338 pres%R = qr_prim_rsx_vf(j, k, l + 1, eqn_idx%E)
3339
3340 ! Hypoelasticity
3341
3342# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3343#if defined(MFC_OpenACC)
3344# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3345!$acc loop seq
3346# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3347#elif defined(MFC_OpenMP)
3348# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3349
3350# 270 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3351#endif
3352 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
3353 tau_e_l(i) = ql_prim_rsx_vf(j, k, l, eqn_idx%stress%beg - 1 + i)
3354 tau_e_r(i) = qr_prim_rsx_vf(j, k, l + 1, eqn_idx%stress%beg - 1 + i)
3355 end do
3356
3357 u_t2_l = 0._wp; u_t2_r = 0._wp
3358 tau_nt2_l = 0._wp; tau_nt2_r = 0._wp
3359 tau_t2t2_l = 0._wp; tau_t2t2_r = 0._wp
3360 tau_t1t2_l = 0._wp; tau_t1t2_r = 0._wp
3361
3362 ! Map physical-basis arrays to directional aliases via stress_perm/dir_idx
3363 u_n_l = vel%L(dir_idx(1)); u_n_r = vel%R(dir_idx(1))
3364 tau_nn_l = tau_e_l(stress_perm(1)); tau_nn_r = tau_e_r(stress_perm(1))
3365 if (n == 0) then
3366 ncomp = 11
3367 else if (p == 0) then
3368 ncomp = 11
3369 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
3370 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
3371 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
3372 else
3373 ncomp = 14
3374 u_t_l = vel%L(dir_idx(2)); u_t_r = vel%R(dir_idx(2))
3375 u_t2_l = vel%L(dir_idx(3)); u_t2_r = vel%R(dir_idx(3))
3376 tau_nt_l = tau_e_l(stress_perm(2)); tau_nt_r = tau_e_r(stress_perm(2))
3377 tau_tt_l = tau_e_l(stress_perm(3)); tau_tt_r = tau_e_r(stress_perm(3))
3378 tau_nt2_l = tau_e_l(stress_perm(4)); tau_nt2_r = tau_e_r(stress_perm(4))
3379 tau_t1t2_l = tau_e_l(stress_perm(5)); tau_t1t2_r = tau_e_r(stress_perm(5))
3380 tau_t2t2_l = tau_e_l(stress_perm(6)); tau_t2t2_r = tau_e_r(stress_perm(6))
3381 end if
3382 if (cyl_coord) then
3383 tau_qq_l = tau_e_l(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
3384 tau_qq_r = tau_e_r(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
3385 else
3386 tau_qq_l = 0._wp; tau_qq_r = 0._wp
3387 end if
3388 ! Total pressure (replace the usual pressure to define SM)
3389 ptot_l = pres%L - tau_nn_l
3390 ptot_r = pres%R - tau_nn_r
3391
3392 ! Symmetrize total pressure when it differs only by floating-point roundoff. WENO reconstruction of a
3393 ! uniform field can produce slightly different L/R values at material interfaces due to different
3394 ! smoothness indicators. With stiff materials (G~1e9), even 1e-12 relative pTot asymmetry creates O(1)
3395 ! spurious stress through the HLLD star-state.
3396 if (abs(ptot_r - ptot_l) < 1e-12_wp*max(abs(ptot_l), abs(ptot_r), 1._wp)) then
3397 ptot_l = 5e-1_wp*(ptot_l + ptot_r)
3398 ptot_r = ptot_l
3399 end if
3400
3401 ! Sum properties of all fluid components
3402 rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp
3403 rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp
3404
3405# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3406#if defined(MFC_OpenACC)
3407# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3408!$acc loop seq
3409# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3410#elif defined(MFC_OpenMP)
3411# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3412
3413# 323 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3414#endif
3415 do i = 1, num_fluids
3416 rho%L = rho%L + alpha_rho_l(i)
3417 gamma%L = gamma%L + alpha_l(i)*gammas(i)
3418 pi_inf%L = pi_inf%L + alpha_l(i)*pi_infs(i)
3419 qv%L = qv%L + alpha_rho_l(i)*qvs(i)
3420
3421 rho%R = rho%R + alpha_rho_r(i)
3422 gamma%R = gamma%R + alpha_r(i)*gammas(i)
3423 pi_inf%R = pi_inf%R + alpha_r(i)*pi_infs(i)
3424 qv%R = qv%R + alpha_rho_r(i)*qvs(i)
3425 end do
3426
3427 g_l = 0._wp; g_r = 0._wp
3428
3429# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3430#if defined(MFC_OpenACC)
3431# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3432!$acc loop seq
3433# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3434#elif defined(MFC_OpenMP)
3435# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3436
3437# 337 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3438#endif
3439 do i = 1, num_fluids
3440 g_l = g_l + alpha_l(i)*gs_rs(i)
3441 g_r = g_r + alpha_r(i)*gs_rs(i)
3442 end do
3443
3444 e%L = gamma%L*pres%L + pi_inf%L + 5e-1_wp*rho%L*vel_rms%L + qv%L
3445 e%R = gamma%R*pres%R + pi_inf%R + 5e-1_wp*rho%R*vel_rms%R + qv%R
3446
3447 ! Freeze the thermal/kinetic enthalpy used by the EOS sound-speed call before
3448 ! adding hypoelastic strain energy to the conservative total energy.
3449 h%L = (e%L + pres%L)/rho%L
3450 h%R = (e%R + pres%R)/rho%R
3451
3452
3453# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3454#if defined(MFC_OpenACC)
3455# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3456!$acc loop seq
3457# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3458#elif defined(MFC_OpenMP)
3459# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3460
3461# 351 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3462#endif
3463 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
3464 if (g_l > verysmall) then
3465# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3466 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
3467# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3468 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
3469# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3470 e%L = e%L + (tau_e_l(i)*tau_e_l(i))/max(4._wp*g_l, verysmall)
3471# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3472 end if
3473# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3474 end if
3475# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3476 if (g_r > verysmall) then
3477# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3478 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
3479# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3480 if ((n > 0 .and. p == 0 .and. i == 2) .or. (p > 0 .and. (i == 2 .or. i == 4 .or. i == 5))) then
3481# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3482 e%R = e%R + (tau_e_r(i)*tau_e_r(i))/max(4._wp*g_r, verysmall)
3483# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3484 end if
3485# 353 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3486 end if
3487# 356 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3488 end do
3489
3490 ! Compute Riemann states
3491
3492 call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, h%L, alpha_l, vel_rms%L, 0._wp, c%L, &
3493 & qv%L)
3494 call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, h%R, alpha_r, vel_rms%R, 0._wp, c%R, &
3495 & qv%R)
3496
3497 s_l = min(u_n_l - sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)), &
3498 & u_n_r - sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)))
3499 s_r = max(u_n_r + sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R)), &
3500 & u_n_l + sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L)))
3501
3502 if (p > 0 .and. .not. cyl_coord) then
3503 ! 3D Cartesian: 14-state compact basis
3504 u_l(1) = alpha_rho_l(1); u_r(1) = alpha_rho_r(1)
3505 u_l(2) = alpha_rho_l(2); u_r(2) = alpha_rho_r(2)
3506 u_l(3) = rho%L*u_n_l; u_r(3) = rho%R*u_n_r
3507 u_l(4) = rho%L*u_t_l; u_r(4) = rho%R*u_t_r
3508 u_l(5) = rho%L*u_t2_l; u_r(5) = rho%R*u_t2_r
3509 u_l(6) = e%L; u_r(6) = e%R
3510 u_l(7) = alpha_l(1); u_r(7) = alpha_r(1)
3511 u_l(8) = alpha_l(2); u_r(8) = alpha_r(2)
3512 u_l(9) = rho%L*tau_nn_l; u_r(9) = rho%R*tau_nn_r
3513 u_l(10) = rho%L*tau_nt_l; u_r(10) = rho%R*tau_nt_r
3514 u_l(11) = rho%L*tau_nt2_l; u_r(11) = rho%R*tau_nt2_r
3515 u_l(12) = rho%L*tau_tt_l; u_r(12) = rho%R*tau_tt_r
3516 u_l(13) = rho%L*tau_t2t2_l; u_r(13) = rho%R*tau_t2t2_r
3517 u_l(14) = rho%L*tau_t1t2_l; u_r(14) = rho%R*tau_t1t2_r
3518
3519 f_l(1) = u_l(1)*u_n_l; f_r(1) = u_r(1)*u_n_r
3520 f_l(2) = u_l(2)*u_n_l; f_r(2) = u_r(2)*u_n_r
3521 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
3522 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
3523 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
3524 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
3525 f_l(5) = rho%L*u_n_l*u_t2_l - tau_nt2_l
3526 f_r(5) = rho%R*u_n_r*u_t2_r - tau_nt2_r
3527 f_l(6) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l - u_t2_l*tau_nt2_l
3528 f_r(6) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r - u_t2_r*tau_nt2_r
3529 ! Rows 7-14 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
3530 ! inside the per-anchor pass loop below.
3531 else
3532 ! 2D/axisym: 11-state compact basis (unchanged)
3533 u_l(1) = alpha_rho_l(1)
3534 u_l(2) = alpha_rho_l(2)
3535 u_l(3) = rho%L*u_n_l
3536 u_l(4) = rho%L*u_t_l
3537 u_l(5) = e%L
3538 u_l(6) = alpha_l(1)
3539 u_l(7) = alpha_l(2)
3540 u_l(8) = rho%L*tau_nn_l
3541 u_l(9) = rho%L*tau_nt_l
3542 u_l(10) = rho%L*tau_tt_l
3543 u_l(11) = rho%L*tau_qq_l
3544
3545 u_r(1) = alpha_rho_r(1)
3546 u_r(2) = alpha_rho_r(2)
3547 u_r(3) = rho%R*u_n_r
3548 u_r(4) = rho%R*u_t_r
3549 u_r(5) = e%R
3550 u_r(6) = alpha_r(1)
3551 u_r(7) = alpha_r(2)
3552 u_r(8) = rho%R*tau_nn_r
3553 u_r(9) = rho%R*tau_nt_r
3554 u_r(10) = rho%R*tau_tt_r
3555 u_r(11) = rho%R*tau_qq_r
3556
3557 f_l(1) = u_l(1)*u_n_l
3558 f_l(2) = u_l(2)*u_n_l
3559 f_l(3) = rho%L*u_n_l*u_n_l + ptot_l
3560 f_l(4) = rho%L*u_n_l*u_t_l - tau_nt_l
3561 f_l(5) = (e%L + ptot_l)*u_n_l - u_t_l*tau_nt_l
3562
3563 f_r(1) = u_r(1)*u_n_r
3564 f_r(2) = u_r(2)*u_n_r
3565 f_r(3) = rho%R*u_n_r*u_n_r + ptot_r
3566 f_r(4) = rho%R*u_n_r*u_t_r - tau_nt_r
3567 f_r(5) = (e%R + ptot_r)*u_n_r - u_t_r*tau_nt_r
3568 ! Rows 6-11 (volume fractions + stresses) carry the anchor-dependent hat coefficients and are filled
3569 ! inside the per-anchor pass loop below.
3570 end if
3571
3572 a_l = rho%L*(s_l - u_n_l)
3573 a_r = rho%R*(s_r - u_n_r)
3574 denoma = (a_r - a_l)
3575
3576 s_m = ((ptot_r - ptot_l) + a_l*u_n_l - a_r*u_n_r)/(a_l - a_r + verysmall)
3577
3578 ! Degenerate wave structure: denom ~ 0 or S_M not in [S_L,S_R]. The test is anchor-independent, so both
3579 ! anchored solves below take the same branch.
3580 degenerate = (abs(denoma) < verysmall .or. .not. (s_l - verysmall <= s_m .and. s_m <= s_r + verysmall))
3581
3582 if (.not. degenerate) then
3583 ! Anchor-independent pieces of the star region (the anchor state enters only the volume-fraction and
3584 ! stress star states)
3585 ptot_star = ptot_l + a_l*(s_m - u_n_l)
3586
3587 ! Signed floor (HLLC-style, see m_riemann_solver_hllc.fpp) on the wave-fan denominators: guards the
3588 ! degenerate S_M -> S_L / S_M -> S_R limit, sign-preserving, and a no-op away from it (|denom| >>
3589 ! verysmall)
3590 rhol_star = rho%L*(s_l - u_n_l)/min(s_l - s_m, -verysmall)
3591 rhor_star = rho%R*(s_r - u_n_r)/max(s_r - s_m, verysmall)
3592 fac_l = (s_l - u_n_l)/min(s_l - s_m, -verysmall)
3593 fac_r = (s_r - u_n_r)/max(s_r - s_m, verysmall)
3594
3595 e_l_star = (e%L*(u_n_l - s_l) + u_n_l*ptot_l - s_m*ptot_star)/max(s_m - s_l, verysmall)
3596 e_r_star = (e%R*(u_n_r - s_r) + u_n_r*ptot_r - s_m*ptot_star)/min(s_m - s_r, -verysmall)
3597
3598 if (riemann_hypo_adc) then
3599 ! ADC sensors depend only on the L/R face states: computed once, shared by both anchored solves
3600 sigma_l = ptot_l
3601 sigma_r = ptot_r
3602 dsigma = sigma_r - sigma_l
3603 sigma_ref = max(max(abs(sigma_l), abs(sigma_r)), verysmall)
3604
3605 a_l_ref = sqrt(max(verysmall, c%L*c%L + ((4._wp/3._wp)*g_l + tau_nn_l)/rho%L))
3606 a_r_ref = sqrt(max(verysmall, c%R*c%R + ((4._wp/3._wp)*g_r + tau_nn_r)/rho%R))
3607 a_ref = max(max(a_l_ref, a_r_ref), verysmall)
3608
3609 du_t = u_t_r - u_t_l
3610 dtau_nt = tau_nt_r - tau_nt_l
3611 du_t2 = u_t2_r - u_t2_l
3612 dtau_nt2 = tau_nt2_r - tau_nt2_l
3613
3614 sensor_ptot = (dsigma*dsigma)/((adc_kappa*sigma_ref)**2 + verysmall)
3615 sensor_vt = (du_t*du_t + du_t2*du_t2)/((adc_kappa*a_ref)**2 + verysmall)
3616 sensor_tnt = (dtau_nt*dtau_nt + dtau_nt2*dtau_nt2)/((adc_kappa*sigma_ref)**2 + verysmall)
3617
3618 sensor_combined = sensor_ptot + sensor_tnt + sensor_vt
3619
3620 phi = exp(-(sensor_combined**adc_power))
3621 end if
3622 end if
3623
3624 ! Fused dual-pass: both anchored solves share everything above. The anchor (hat) state and everything it
3625 ! touches is evaluated per pass: pass 1 anchors on cell j (hat_L) and writes the flux_rs* set; pass 2
3626 ! anchors on cell j+1 (hat_R) and writes the flux_hatR_rs* set.
3627
3628# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3629#if defined(MFC_OpenACC)
3630# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3631!$acc loop seq
3632# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3633#elif defined(MFC_OpenMP)
3634# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3635
3636# 495 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3637#endif
3638 do ipass = 1, 2
3639 do i = 1, eqn_idx%cont%end
3640 alpha_rho_hat(i) = q_prim_vf(i)%sf(j, k, l + ipass - 1)
3641 end do
3642 do i = 1, num_fluids
3643 alpha_hat(i) = q_prim_vf(eqn_idx%E + i)%sf(j, k, l + ipass - 1)
3644 end do
3645
3646# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3647#if defined(MFC_OpenACC)
3648# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3649!$acc loop seq
3650# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3651#elif defined(MFC_OpenMP)
3652# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3653
3654# 503 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3655#endif
3656 do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1
3657 tau_e_hat(i) = q_prim_vf(eqn_idx%stress%beg - 1 + i)%sf(j, k, l + ipass - 1)
3658 end do
3659
3660 ! Anchor-state directional aliases (mirrors the L/R alias block above)
3661 tau_nt2_hat = 0._wp; tau_t2t2_hat = 0._wp; tau_t1t2_hat = 0._wp
3662 tau_nn_hat = tau_e_hat(stress_perm(1))
3663 if (n > 0) then
3664 tau_nt_hat = tau_e_hat(stress_perm(2))
3665 tau_tt_hat = tau_e_hat(stress_perm(3))
3666 if (p > 0) then
3667 tau_nt2_hat = tau_e_hat(stress_perm(4))
3668 tau_t1t2_hat = tau_e_hat(stress_perm(5))
3669 tau_t2t2_hat = tau_e_hat(stress_perm(6))
3670 end if
3671 end if
3672 if (cyl_coord) then
3673 tau_qq_hat = tau_e_hat(eqn_idx%stress%end - eqn_idx%stress%beg + 1)
3674 else
3675 tau_qq_hat = 0._wp
3676 end if
3677
3678 rho_hat = 0._wp
3679
3680# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3681#if defined(MFC_OpenACC)
3682# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3683!$acc loop seq
3684# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3685#elif defined(MFC_OpenMP)
3686# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3687
3688# 527 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3689#endif
3690 do i = 1, num_fluids
3691 rho_hat = rho_hat + alpha_rho_hat(i)
3692 end do
3693
3694 g_hat = 0._wp
3695
3696# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3697#if defined(MFC_OpenACC)
3698# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3699!$acc loop seq
3700# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3701#elif defined(MFC_OpenMP)
3702# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3703
3704# 533 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3705#endif
3706 do i = 1, num_fluids
3707 g_hat = g_hat + alpha_hat(i)*gs_rs(i)
3708 end do
3709
3710 ! Two-component 2D only (enforced by checker restrictions)
3711 k_hat = 0._wp
3712 if (alt_soundspeed) then
3713 pres_hat = q_prim_vf(eqn_idx%E)%sf(j, k, l + ipass - 1)
3714 blkmod1_hat = ((gammas(1) + 1._wp)*pres_hat + pi_infs(1))/gammas(1) + (4._wp/3._wp)*gs_rs(1)
3715 blkmod2_hat = ((gammas(2) + 1._wp)*pres_hat + pi_infs(2))/gammas(2) + (4._wp/3._wp)*gs_rs(2)
3716 k_hat = alpha_hat(1)*alpha_hat(2)*(blkmod2_hat - blkmod1_hat)/(alpha_hat(1)*blkmod2_hat &
3717 & + alpha_hat(2)*blkmod1_hat + verysmall)
3718 end if
3719 c_hat_1 = alpha_hat(1) + k_hat
3720 c_hat_2 = alpha_hat(2) - k_hat
3721
3722 if (p > 0 .and. .not. cyl_coord) then
3723 ! 3D Cartesian: anchor-dependent rows (7-14) of the 14-state flux
3724 f_l(7) = u_l(7)*u_n_l - c_hat_1*u_n_l
3725 f_r(7) = u_r(7)*u_n_r - c_hat_1*u_n_r
3726 f_l(8) = u_l(8)*u_n_l - c_hat_2*u_n_l
3727 f_r(8) = u_r(8)*u_n_r - c_hat_2*u_n_r
3728 f_l(9) = u_l(9)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
3729 f_r(9) = u_r(9)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
3730 f_l(10) = u_l(10)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
3731 f_r(10) = u_r(10)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
3732 f_l(11) = u_l(11)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t2_l
3733 f_r(11) = u_r(11)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t2_r
3734 f_l(12) = u_l(12)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
3735 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
3736 f_r(12) = u_r(12)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
3737 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
3738 f_l(13) = u_l(13)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_l &
3739 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_l
3740 f_r(13) = u_r(13)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_t2t2_hat)*u_n_r &
3741 & - 2._wp*rho_hat*tau_nt2_hat*u_t2_r
3742 f_l(14) = u_l(14)*u_n_l + rho_hat*tau_t1t2_hat*u_n_l - rho_hat*tau_nt2_hat*u_t_l &
3743 & - rho_hat*tau_nt_hat*u_t2_l
3744 f_r(14) = u_r(14)*u_n_r + rho_hat*tau_t1t2_hat*u_n_r - rho_hat*tau_nt2_hat*u_t_r &
3745 & - rho_hat*tau_nt_hat*u_t2_r
3746 else
3747 ! 2D/axisym: anchor-dependent rows (6-11) of the 11-state flux
3748 f_l(6) = u_l(6)*u_n_l - c_hat_1*u_n_l
3749 f_r(6) = u_r(6)*u_n_r - c_hat_1*u_n_r
3750 f_l(7) = u_l(7)*u_n_l - c_hat_2*u_n_l
3751 f_r(7) = u_r(7)*u_n_r - c_hat_2*u_n_r
3752 f_l(8) = u_l(8)*u_n_l - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_l
3753 f_r(8) = u_r(8)*u_n_r - rho_hat*(4._wp/3._wp*g_hat + tau_nn_hat)*u_n_r
3754 f_l(9) = u_l(9)*u_n_l - rho_hat*(g_hat + tau_nn_hat)*u_t_l
3755 f_r(9) = u_r(9)*u_n_r - rho_hat*(g_hat + tau_nn_hat)*u_t_r
3756 f_l(10) = u_l(10)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_l &
3757 & - 2._wp*rho_hat*tau_nt_hat*u_t_l
3758 f_r(10) = u_r(10)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_tt_hat)*u_n_r &
3759 & - 2._wp*rho_hat*tau_nt_hat*u_t_r
3760 f_l(11) = u_l(11)*u_n_l + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_l
3761 f_r(11) = u_r(11)*u_n_r + rho_hat*(2._wp/3._wp*g_hat + tau_qq_hat)*u_n_r
3762 end if
3763
3764 ! The effective shear stiffness is anchor-dependent. Resolve its three numerical states before
3765 ! forming C_NC: positive keeps HLLD; zero to cancellation accuracy takes the finite HLLC limit;
3766 ! materially negative (loss of the assumed real shear subfan) rejects the whole anchored fan.
3767 ! The tolerance is relative only to the two terms being added, not to an acoustic/material scale.
3768 fan_fallback = degenerate
3769 shear_degenerate = .false.
3770 if (.not. fan_fallback) then
3771 g_eff = g_hat + tau_nn_hat
3772 g_eff_tol = g_eff_roundoff_factor*epsilon(1._wp)*(abs(g_hat) + abs(tau_nn_hat))
3773
3774 if (.not. (g_eff >= -g_eff_tol)) then
3775 ! Materially negative, or unordered (NaN): no real five-wave shear fan.
3776 fan_fallback = .true.
3777 else if (g_eff <= g_eff_tol) then
3778 shear_degenerate = .true.
3779 s_lstar = s_m
3780 s_rstar = s_m
3781 else
3782 c_nc = rho_hat*g_eff
3783 if (.not. (c_nc > 0._wp)) then
3784 ! Positive G_eff below the representable C_NC range is numerically degenerate;
3785 ! nonpositive/unordered rho_hat is invalid for the same construction.
3786 shear_degenerate = (rho_hat > 0._wp)
3787 fan_fallback = .not. shear_degenerate
3788 s_lstar = s_m
3789 s_rstar = s_m
3790 else
3791 sqrtc_nc = sqrt(c_nc)
3792 s_lstar = s_m - sqrtc_nc/rhol_star
3793 s_rstar = s_m + sqrtc_nc/rhor_star
3794 ! A speed-only clamp would break the corresponding Rankine--Hugoniot jump.
3795 fan_fallback = (s_lstar < s_l .or. s_rstar > s_r)
3796 end if
3797 end if
3798 end if
3799
3800 if (fan_fallback) then
3801 ! HLL (or one-sided) fallback for an invalid wave structure
3802 if (s_l < 0._wp .and. s_r > 0._wp) then
3803 do i = 1, ncomp
3804 f_hlld(i) = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
3805 end do
3806 else if (s_l >= 0._wp) then
3807 f_hlld(1:ncomp) = f_l(1:ncomp)
3808 else
3809 f_hlld(1:ncomp) = f_r(1:ncomp)
3810 end if
3811 ! Initialize star-state variables to safe values so no path reads uninitialized memory
3812 ! (a subsequent valid pass restores what it needs). Fallback face exports do not use
3813 ! them: they take the HLL/one-sided traces computed below.
3814 ptot_star = 5e-1_wp*(ptot_l + ptot_r)
3815 s_lstar = s_l
3816 s_rstar = s_r
3817 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
3818 tau_nn_l_star = tau_nn_l
3819 tau_nn_r_star = tau_nn_r
3820 tau_qq_l_star = tau_qq_l
3821 tau_qq_r_star = tau_qq_r
3822 else
3823 ! A preceding anchored pass may have taken the fallback and assigned a safe face value.
3824 ! Restore the anchor-independent HLLD contact pressure for this valid pass.
3825 ptot_star = ptot_l + a_l*(s_m - u_n_l)
3826
3827 if (shear_degenerate) then
3828 ! Degenerate shear impedance: collapse inner waves to HLLC
3829 u_t_star = 5e-1_wp*(u_t_l + u_t_r)
3830 tau_nt_star = 5e-1_wp*(tau_nt_l + tau_nt_r)
3831 u_t2_star = 5e-1_wp*(u_t2_l + u_t2_r)
3832 tau_nt2_star = 5e-1_wp*(tau_nt2_l + tau_nt2_r)
3833 else
3834 u_t_star = 5e-1_wp*((tau_nt_r - tau_nt_l)/sqrtc_nc + (u_t_r + u_t_l))
3835 tau_nt_star = 5e-1_wp*((u_t_r - u_t_l)*sqrtc_nc + (tau_nt_r + tau_nt_l))
3836 u_t2_star = 5e-1_wp*((tau_nt2_r - tau_nt2_l)/sqrtc_nc + (u_t2_r + u_t2_l))
3837 tau_nt2_star = 5e-1_wp*((u_t2_r - u_t2_l)*sqrtc_nc + (tau_nt2_r + tau_nt2_l))
3838 end if
3839
3840 ! Outer-wave stress star states: one formula family over the components. ELC is
3841 ! the anchor-side elastic coefficient (deviatoric 4/3 vs 2/3 structure; t1t2
3842 ! carries no G term) and SGN = -1/+1 the jump sign of the component.
3843# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3844# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3845 tau_nn_l_star = tau_nn_l - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
3846# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3847 tau_nn_r_star = tau_nn_r - (rho_hat*(g_hat*4._wp/3._wp + tau_nn_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
3848# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3849# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3850# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3851 tau_tt_l_star = tau_tt_l + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
3852# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3853 tau_tt_r_star = tau_tt_r + (rho_hat*(g_hat*2._wp/3._wp + tau_tt_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
3854# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3855# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3856# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3857 tau_t2t2_l_star = tau_t2t2_l + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
3858# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3859 tau_t2t2_r_star = tau_t2t2_r + (rho_hat*(g_hat*2._wp/3._wp + tau_t2t2_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
3860# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3861# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3862# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3863 tau_t1t2_l_star = tau_t1t2_l + (rho_hat*tau_t1t2_hat*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
3864# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3865 tau_t1t2_r_star = tau_t1t2_r + (rho_hat*tau_t1t2_hat*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
3866# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3867# 676 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3868# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3869 tau_qq_l_star = tau_qq_l + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_l - s_m))/(rho%L*(u_n_l - s_l))
3870# 677 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3871 tau_qq_r_star = tau_qq_r + (rho_hat*(g_hat*2._wp/3._wp + tau_qq_hat)*(u_n_r - s_m))/(rho%R*(u_n_r - s_r))
3872# 679 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3873# 680 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3874
3875 if (shear_degenerate) then
3876 ! Degenerate: no inner wave correction
3877 tau_tt_l_starstar = tau_tt_l_star
3878 tau_tt_r_starstar = tau_tt_r_star
3879 tau_t2t2_l_starstar = tau_t2t2_l_star
3880 tau_t2t2_r_starstar = tau_t2t2_r_star
3881 tau_t1t2_l_starstar = tau_t1t2_l_star
3882 tau_t1t2_r_starstar = tau_t1t2_r_star
3883 e_l_starstar = e_l_star
3884 e_r_starstar = e_r_star
3885 else
3886 tau_tt_l_starstar = tau_tt_l_star + 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_l)
3887 tau_tt_r_starstar = tau_tt_r_star - 2._wp*rho_hat*tau_nt_hat/sqrtc_nc*(u_t_star - u_t_r)
3888 tau_t2t2_l_starstar = tau_t2t2_l_star + 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
3889 & - u_t2_l)
3890 tau_t2t2_r_starstar = tau_t2t2_r_star - 2._wp*rho_hat*tau_nt2_hat/sqrtc_nc*(u_t2_star &
3891 & - u_t2_r)
3892 tau_t1t2_l_starstar = tau_t1t2_l_star + rho_hat*(tau_nt2_hat*(u_t_star - u_t_l) &
3893 & + tau_nt_hat*(u_t2_star - u_t2_l))/sqrtc_nc
3894 tau_t1t2_r_starstar = tau_t1t2_r_star - rho_hat*(tau_nt2_hat*(u_t_star - u_t_r) &
3895 & + tau_nt_hat*(u_t2_star - u_t2_r))/sqrtc_nc
3896 e_l_starstar = e_l_star + (rhol_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_l*tau_nt_l) &
3897 & + (u_t2_star*tau_nt2_star - u_t2_l*tau_nt2_l))
3898 e_r_starstar = e_r_star - (rhor_star/sqrtc_nc)*((u_t_star*tau_nt_star - u_t_r*tau_nt_r) &
3899 & + (u_t2_star*tau_nt2_star - u_t2_r*tau_nt2_r))
3900 end if
3901
3902 alpha1_l_star = (alpha_l(1)*(s_l - u_n_l) - c_hat_1*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
3903 alpha1_r_star = (alpha_r(1)*(s_r - u_n_r) - c_hat_1*(s_m - u_n_r))/max(s_r - s_m, verysmall)
3904
3905 alpha2_l_star = (alpha_l(2)*(s_l - u_n_l) - c_hat_2*(s_m - u_n_l))/min(s_l - s_m, -verysmall)
3906 alpha2_r_star = (alpha_r(2)*(s_r - u_n_r) - c_hat_2*(s_m - u_n_r))/max(s_r - s_m, verysmall)
3907
3908 ! HLLD flux, register-diet form: pick the wave-fan zone once (it is
3909 ! component-independent), then fold the selected side's star/starstar states into
3910 ! F_hlld one component at a time through the scalars us_c/uss_c (no fan arrays
3911 ! survive). The L and R sides are mirror images and the per-component statements
3912 ! share one shape, so the whole fold is emitted from one Fypp template driven by
3913 ! HLLD_FAN_SIDES and the HLLD_FAN_COMPS_3D/2D tables above. Per-component operation
3914 ! order matches the materialized form, so the flux is -O0 bit-identical. Do NOT
3915 ! re-expand into per-region temp arrays (or reorder the fold) without re-checking
3916 ! GPU register spill and the -O0 exactness gate.
3917
3918 zone = f_hlld_wave_zone(s_l, s_lstar, s_m, s_rstar, s_r)
3919
3920 if (zone == 0) then
3921 f_hlld(1:ncomp) = f_l(1:ncomp)
3922 else if (zone == 5) then
3923 f_hlld(1:ncomp) = f_r(1:ncomp)
3924# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3925 else if (zone == 1 .or. zone == 2) then
3926 ! L side of the fan: per component, us_c/uss_c are the selected side's
3927 ! star/starstar states (the old F_starL is folded into the first F_hlld
3928 ! statement; the starstar correction applies in zone 2 only, with the
3929 ! left-associative order of the materialized form preserved)
3930 if (p > 0 .and. .not. cyl_coord) then
3931# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3932 us_c = u_l(1)*fac_l
3933 uss_c = us_c
3934 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
3935 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
3936 & - us_c)
3937# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3938 us_c = u_l(2)*fac_l
3939 uss_c = us_c
3940 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
3941 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
3942 & - us_c)
3943# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3944 us_c = rhol_star*s_m
3945 uss_c = us_c
3946 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
3947 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
3948 & - us_c)
3949# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3950 us_c = rhol_star*u_t_l
3951 uss_c = rhol_star*u_t_star
3952 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
3953 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
3954 & - us_c)
3955# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3956 us_c = rhol_star*u_t2_l
3957 uss_c = rhol_star*u_t2_star
3958 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
3959 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
3960 & - us_c)
3961# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3962 us_c = e_l_star
3963 uss_c = e_l_starstar
3964 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
3965 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
3966 & - us_c)
3967# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3968 us_c = alpha1_l_star
3969 uss_c = us_c
3970 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
3971 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
3972 & - us_c)
3973# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3974 us_c = alpha2_l_star
3975 uss_c = us_c
3976 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
3977 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
3978 & - us_c)
3979# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3980 us_c = rhol_star*tau_nn_l_star
3981 uss_c = us_c
3982 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
3983 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
3984 & - us_c)
3985# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3986 us_c = rhol_star*tau_nt_l
3987 uss_c = rhol_star*tau_nt_star
3988 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
3989 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
3990 & - us_c)
3991# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3992 us_c = rhol_star*tau_nt2_l
3993 uss_c = rhol_star*tau_nt2_star
3994 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
3995 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
3996 & - us_c)
3997# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
3998 us_c = rhol_star*tau_tt_l_star
3999 uss_c = rhol_star*tau_tt_l_starstar
4000 f_hlld(12) = f_l(12) + s_l*(us_c - u_l(12))
4001 if (zone == 2) f_hlld(12) = f_hlld(12) + s_lstar*(uss_c &
4002 & - us_c)
4003# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4004 us_c = rhol_star*tau_t2t2_l_star
4005 uss_c = rhol_star*tau_t2t2_l_starstar
4006 f_hlld(13) = f_l(13) + s_l*(us_c - u_l(13))
4007 if (zone == 2) f_hlld(13) = f_hlld(13) + s_lstar*(uss_c &
4008 & - us_c)
4009# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4010 us_c = rhol_star*tau_t1t2_l_star
4011 uss_c = rhol_star*tau_t1t2_l_starstar
4012 f_hlld(14) = f_l(14) + s_l*(us_c - u_l(14))
4013 if (zone == 2) f_hlld(14) = f_hlld(14) + s_lstar*(uss_c &
4014 & - us_c)
4015# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4016 else
4017# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4018 us_c = u_l(1)*fac_l
4019 uss_c = us_c
4020 f_hlld(1) = f_l(1) + s_l*(us_c - u_l(1))
4021 if (zone == 2) f_hlld(1) = f_hlld(1) + s_lstar*(uss_c &
4022 & - us_c)
4023# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4024 us_c = u_l(2)*fac_l
4025 uss_c = us_c
4026 f_hlld(2) = f_l(2) + s_l*(us_c - u_l(2))
4027 if (zone == 2) f_hlld(2) = f_hlld(2) + s_lstar*(uss_c &
4028 & - us_c)
4029# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4030 us_c = rhol_star*s_m
4031 uss_c = us_c
4032 f_hlld(3) = f_l(3) + s_l*(us_c - u_l(3))
4033 if (zone == 2) f_hlld(3) = f_hlld(3) + s_lstar*(uss_c &
4034 & - us_c)
4035# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4036 us_c = rhol_star*u_t_l
4037 uss_c = rhol_star*u_t_star
4038 f_hlld(4) = f_l(4) + s_l*(us_c - u_l(4))
4039 if (zone == 2) f_hlld(4) = f_hlld(4) + s_lstar*(uss_c &
4040 & - us_c)
4041# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4042 us_c = e_l_star
4043 uss_c = e_l_starstar
4044 f_hlld(5) = f_l(5) + s_l*(us_c - u_l(5))
4045 if (zone == 2) f_hlld(5) = f_hlld(5) + s_lstar*(uss_c &
4046 & - us_c)
4047# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4048 us_c = alpha1_l_star
4049 uss_c = us_c
4050 f_hlld(6) = f_l(6) + s_l*(us_c - u_l(6))
4051 if (zone == 2) f_hlld(6) = f_hlld(6) + s_lstar*(uss_c &
4052 & - us_c)
4053# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4054 us_c = alpha2_l_star
4055 uss_c = us_c
4056 f_hlld(7) = f_l(7) + s_l*(us_c - u_l(7))
4057 if (zone == 2) f_hlld(7) = f_hlld(7) + s_lstar*(uss_c &
4058 & - us_c)
4059# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4060 us_c = rhol_star*tau_nn_l_star
4061 uss_c = us_c
4062 f_hlld(8) = f_l(8) + s_l*(us_c - u_l(8))
4063 if (zone == 2) f_hlld(8) = f_hlld(8) + s_lstar*(uss_c &
4064 & - us_c)
4065# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4066 us_c = rhol_star*tau_nt_l
4067 uss_c = rhol_star*tau_nt_star
4068 f_hlld(9) = f_l(9) + s_l*(us_c - u_l(9))
4069 if (zone == 2) f_hlld(9) = f_hlld(9) + s_lstar*(uss_c &
4070 & - us_c)
4071# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4072 us_c = rhol_star*tau_tt_l_star
4073 uss_c = rhol_star*tau_tt_l_starstar
4074 f_hlld(10) = f_l(10) + s_l*(us_c - u_l(10))
4075 if (zone == 2) f_hlld(10) = f_hlld(10) + s_lstar*(uss_c &
4076 & - us_c)
4077# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4078 us_c = rhol_star*tau_qq_l_star
4079 uss_c = us_c
4080 f_hlld(11) = f_l(11) + s_l*(us_c - u_l(11))
4081 if (zone == 2) f_hlld(11) = f_hlld(11) + s_lstar*(uss_c &
4082 & - us_c)
4083# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4084 end if
4085# 731 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4086 else if (zone == 3 .or. zone == 4) then
4087 ! R side of the fan: per component, us_c/uss_c are the selected side's
4088 ! star/starstar states (the old F_starR is folded into the first F_hlld
4089 ! statement; the starstar correction applies in zone 3 only, with the
4090 ! left-associative order of the materialized form preserved)
4091 if (p > 0 .and. .not. cyl_coord) then
4092# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4093 us_c = u_r(1)*fac_r
4094 uss_c = us_c
4095 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
4096 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
4097 & - us_c)
4098# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4099 us_c = u_r(2)*fac_r
4100 uss_c = us_c
4101 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
4102 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
4103 & - us_c)
4104# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4105 us_c = rhor_star*s_m
4106 uss_c = us_c
4107 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
4108 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
4109 & - us_c)
4110# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4111 us_c = rhor_star*u_t_r
4112 uss_c = rhor_star*u_t_star
4113 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
4114 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
4115 & - us_c)
4116# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4117 us_c = rhor_star*u_t2_r
4118 uss_c = rhor_star*u_t2_star
4119 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
4120 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
4121 & - us_c)
4122# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4123 us_c = e_r_star
4124 uss_c = e_r_starstar
4125 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
4126 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
4127 & - us_c)
4128# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4129 us_c = alpha1_r_star
4130 uss_c = us_c
4131 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
4132 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
4133 & - us_c)
4134# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4135 us_c = alpha2_r_star
4136 uss_c = us_c
4137 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
4138 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
4139 & - us_c)
4140# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4141 us_c = rhor_star*tau_nn_r_star
4142 uss_c = us_c
4143 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
4144 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
4145 & - us_c)
4146# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4147 us_c = rhor_star*tau_nt_r
4148 uss_c = rhor_star*tau_nt_star
4149 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
4150 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
4151 & - us_c)
4152# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4153 us_c = rhor_star*tau_nt2_r
4154 uss_c = rhor_star*tau_nt2_star
4155 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
4156 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
4157 & - us_c)
4158# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4159 us_c = rhor_star*tau_tt_r_star
4160 uss_c = rhor_star*tau_tt_r_starstar
4161 f_hlld(12) = f_r(12) + s_r*(us_c - u_r(12))
4162 if (zone == 3) f_hlld(12) = f_hlld(12) + s_rstar*(uss_c &
4163 & - us_c)
4164# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4165 us_c = rhor_star*tau_t2t2_r_star
4166 uss_c = rhor_star*tau_t2t2_r_starstar
4167 f_hlld(13) = f_r(13) + s_r*(us_c - u_r(13))
4168 if (zone == 3) f_hlld(13) = f_hlld(13) + s_rstar*(uss_c &
4169 & - us_c)
4170# 738 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4171 us_c = rhor_star*tau_t1t2_r_star
4172 uss_c = rhor_star*tau_t1t2_r_starstar
4173 f_hlld(14) = f_r(14) + s_r*(us_c - u_r(14))
4174 if (zone == 3) f_hlld(14) = f_hlld(14) + s_rstar*(uss_c &
4175 & - us_c)
4176# 744 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4177 else
4178# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4179 us_c = u_r(1)*fac_r
4180 uss_c = us_c
4181 f_hlld(1) = f_r(1) + s_r*(us_c - u_r(1))
4182 if (zone == 3) f_hlld(1) = f_hlld(1) + s_rstar*(uss_c &
4183 & - us_c)
4184# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4185 us_c = u_r(2)*fac_r
4186 uss_c = us_c
4187 f_hlld(2) = f_r(2) + s_r*(us_c - u_r(2))
4188 if (zone == 3) f_hlld(2) = f_hlld(2) + s_rstar*(uss_c &
4189 & - us_c)
4190# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4191 us_c = rhor_star*s_m
4192 uss_c = us_c
4193 f_hlld(3) = f_r(3) + s_r*(us_c - u_r(3))
4194 if (zone == 3) f_hlld(3) = f_hlld(3) + s_rstar*(uss_c &
4195 & - us_c)
4196# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4197 us_c = rhor_star*u_t_r
4198 uss_c = rhor_star*u_t_star
4199 f_hlld(4) = f_r(4) + s_r*(us_c - u_r(4))
4200 if (zone == 3) f_hlld(4) = f_hlld(4) + s_rstar*(uss_c &
4201 & - us_c)
4202# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4203 us_c = e_r_star
4204 uss_c = e_r_starstar
4205 f_hlld(5) = f_r(5) + s_r*(us_c - u_r(5))
4206 if (zone == 3) f_hlld(5) = f_hlld(5) + s_rstar*(uss_c &
4207 & - us_c)
4208# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4209 us_c = alpha1_r_star
4210 uss_c = us_c
4211 f_hlld(6) = f_r(6) + s_r*(us_c - u_r(6))
4212 if (zone == 3) f_hlld(6) = f_hlld(6) + s_rstar*(uss_c &
4213 & - us_c)
4214# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4215 us_c = alpha2_r_star
4216 uss_c = us_c
4217 f_hlld(7) = f_r(7) + s_r*(us_c - u_r(7))
4218 if (zone == 3) f_hlld(7) = f_hlld(7) + s_rstar*(uss_c &
4219 & - us_c)
4220# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4221 us_c = rhor_star*tau_nn_r_star
4222 uss_c = us_c
4223 f_hlld(8) = f_r(8) + s_r*(us_c - u_r(8))
4224 if (zone == 3) f_hlld(8) = f_hlld(8) + s_rstar*(uss_c &
4225 & - us_c)
4226# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4227 us_c = rhor_star*tau_nt_r
4228 uss_c = rhor_star*tau_nt_star
4229 f_hlld(9) = f_r(9) + s_r*(us_c - u_r(9))
4230 if (zone == 3) f_hlld(9) = f_hlld(9) + s_rstar*(uss_c &
4231 & - us_c)
4232# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4233 us_c = rhor_star*tau_tt_r_star
4234 uss_c = rhor_star*tau_tt_r_starstar
4235 f_hlld(10) = f_r(10) + s_r*(us_c - u_r(10))
4236 if (zone == 3) f_hlld(10) = f_hlld(10) + s_rstar*(uss_c &
4237 & - us_c)
4238# 746 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4239 us_c = rhor_star*tau_qq_r_star
4240 uss_c = us_c
4241 f_hlld(11) = f_r(11) + s_r*(us_c - u_r(11))
4242 if (zone == 3) f_hlld(11) = f_hlld(11) + s_rstar*(uss_c &
4243 & - us_c)
4244# 752 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4245 end if
4246# 754 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4247 end if
4248
4249 ! ADC blending (HLLD / HLL)
4250
4251 if (riemann_hypo_adc) then
4252 ! Register-diet form: the HLL flux enters per component as the scalar F_HLL_c
4253 ! instead of a materialized F_HLL array; outside the subsonic fan F_HLL equals
4254 ! F_hlld and the identity blend is kept explicitly so the arithmetic (including
4255 ! signed-zero behavior) matches the array form bit-for-bit.
4256 ! phi is anchor-independent: computed once in the shared section above
4257 if (s_l < 0._wp .and. s_r > 0._wp) then
4258 do i = 1, ncomp
4259 f_hll_c = (s_r*f_l(i) - s_l*f_r(i) + s_l*s_r*(u_r(i) - u_l(i)))/(s_r - s_l + verysmall)
4260 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
4261 end do
4262 else
4263 do i = 1, ncomp
4264 f_hll_c = f_hlld(i)
4265 f_hlld(i) = f_hll_c + phi*(f_hlld(i) - f_hll_c)
4266 end do
4267 end if
4268 end if
4269 end if
4270
4271 ! HLL face traces for the axisymmetric completion: consumed by the ADC face-state blend on
4272 ! valid fans and by the face exports on fallback faces (whose conservative flux is the
4273 ! matching HLL/one-sided flux). Rows 8/11 carry the pass's anchored folds, so the traces
4274 ! are anchor-dependent, like the ADC reference they generalize.
4275 if (cyl_coord .and. (riemann_hypo_adc .or. fan_fallback)) then
4276 if (0._wp <= s_l) then
4277 u_n_hll_trace = u_n_l; u_t_hll_trace = u_t_l
4278 p_face_hll = pres%L; tau_qq_face_hll = tau_qq_l
4279 else if (s_r <= 0._wp) then
4280 u_n_hll_trace = u_n_r; u_t_hll_trace = u_t_r
4281 p_face_hll = pres%R; tau_qq_face_hll = tau_qq_r
4282 else
4283 u_n_hll_trace = (s_r*u_n_l - s_l*u_n_r)/(s_r - s_l + verysmall)
4284 u_t_hll_trace = (s_r*u_t_l - s_l*u_t_r)/(s_r - s_l + verysmall)
4285 ! Only HLL-state components 1, 2, 3, 8 and 11 feed the axisym trace
4286 u_hll_c = (s_r*u_r(1) - s_l*u_l(1) - (f_r(1) - f_l(1)))/(s_r - s_l + verysmall)
4287 rho_hll = u_hll_c
4288 u_hll_c = (s_r*u_r(2) - s_l*u_l(2) - (f_r(2) - f_l(2)))/(s_r - s_l + verysmall)
4289 rho_hll = rho_hll + u_hll_c
4290 u_hll_c = (s_r*u_r(3) - s_l*u_l(3) - (f_r(3) - f_l(3)))/(s_r - s_l + verysmall)
4291 u_n_hll_cons = u_hll_c/(rho_hll + verysmall)
4292 u_hll_c = (s_r*u_r(8) - s_l*u_l(8) - (f_r(8) - f_l(8)))/(s_r - s_l + verysmall)
4293 tau_nn_hll = u_hll_c/(rho_hll + verysmall)
4294 u_hll_c = (s_r*u_r(11) - s_l*u_l(11) - (f_r(11) - f_l(11)))/(s_r - s_l + verysmall)
4295 tau_qq_face_hll = u_hll_c/(rho_hll + verysmall)
4296 ! This branch implies S_L < 0 < S_R, so component 3 of F_HLL is the interior HLL flux
4297 f_hll_c = (s_r*f_l(3) - s_l*f_r(3) + s_l*s_r*(u_r(3) - u_l(3)))/(s_r - s_l + verysmall)
4298 p_face_hll = f_hll_c - rho_hll*u_n_hll_cons*u_n_hll_cons + tau_nn_hll
4299 end if
4300 end if
4301
4302 ! Reorder F_HLLD for output: pass 1 (hat_L) -> flux_rs*, pass 2 (hat_R) -> flux_hatR_rs*
4303# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4304 if (ipass == 1) then
4305 if (p > 0 .and. .not. cyl_coord) then
4306 ! 3D Cartesian: 14-state -> physical indices
4307 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
4308 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
4309 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
4310 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
4311 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
4312 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
4313 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
4314 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
4315 ! Map local stress to physical stress indices
4316 if (dir_idx(1) == 1) then
4317 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
4318 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
4319 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
4320 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
4321 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
4322 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
4323 else if (dir_idx(1) == 2) then
4324 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
4325 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
4326 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
4327 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
4328 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
4329 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
4330 else
4331 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
4332 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
4333 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
4334 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
4335 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
4336 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
4337 end if
4338 else
4339 ! 2D/axisym: 11-state (unchanged)
4340 flux_rsx_vf(j, k, l, 1) = f_hlld(1)
4341 flux_rsx_vf(j, k, l, 2) = f_hlld(2)
4342 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
4343 flux_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
4344 flux_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
4345 flux_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
4346 flux_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
4347 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
4348 if (dir_idx(1) == 1) then
4349 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
4350 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
4351 else
4352 flux_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
4353 flux_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
4354 end if
4355 if (cyl_coord) then
4356 flux_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
4357 end if
4358 end if
4359 end if
4360# 811 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4361 if (ipass == 2) then
4362 if (p > 0 .and. .not. cyl_coord) then
4363 ! 3D Cartesian: 14-state -> physical indices
4364 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
4365 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
4366 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
4367 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
4368 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(3)) = f_hlld(5)
4369 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(6)
4370 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(7)
4371 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(8)
4372 ! Map local stress to physical stress indices
4373 if (dir_idx(1) == 1) then
4374 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(9) ! tau_nn=tau_xx
4375 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
4376 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(12) ! tau_t1t1=tau_yy
4377 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(11) ! tau_nt2=tau_xz
4378 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(14) ! tau_t1t2=tau_yz
4379 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
4380 else if (dir_idx(1) == 2) then
4381 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
4382 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(10) ! tau_nt1=tau_xy
4383 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(9) ! tau_nn=tau_yy
4384 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(14) ! tau_t1t2=tau_xz
4385 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
4386 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(13) ! tau_t2t2=tau_zz
4387 else
4388 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(12) ! tau_t1t1=tau_xx
4389 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(14) ! tau_t1t2=tau_xy
4390 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(13) ! tau_t2t2=tau_yy
4391 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 3) = f_hlld(10) ! tau_nt1=tau_xz
4392 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 4) = f_hlld(11) ! tau_nt2=tau_yz
4393 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 5) = f_hlld(9) ! tau_nn=tau_zz
4394 end if
4395 else
4396 ! 2D/axisym: 11-state (unchanged)
4397 flux_hatr_rsx_vf(j, k, l, 1) = f_hlld(1)
4398 flux_hatr_rsx_vf(j, k, l, 2) = f_hlld(2)
4399 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(1)) = f_hlld(3)
4400 flux_hatr_rsx_vf(j, k, l, eqn_idx%cont%end + dir_idx(2)) = f_hlld(4)
4401 flux_hatr_rsx_vf(j, k, l, eqn_idx%E) = f_hlld(5)
4402 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 1) = f_hlld(6)
4403 flux_hatr_rsx_vf(j, k, l, eqn_idx%E + 2) = f_hlld(7)
4404 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 1) = f_hlld(9)
4405 if (dir_idx(1) == 1) then
4406 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(8)
4407 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(10)
4408 else
4409 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg) = f_hlld(10)
4410 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%beg + 2) = f_hlld(8)
4411 end if
4412 if (cyl_coord) then
4413 flux_hatr_rsx_vf(j, k, l, eqn_idx%stress%end) = f_hlld(11)
4414 end if
4415 end if
4416 end if
4417# 868 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4418
4419 ! Export face velocities for axisym hypo source terms
4420 if (grid_geometry == 2) then
4421 if (fan_fallback) then
4422 ! Fallback face: the conservative flux is the HLL/one-sided flux, so export the
4423 ! matching HLL/one-sided traces, not the rejected fan's contact speed/star states
4424 u_n_face = u_n_hll_trace; u_t_face = u_t_hll_trace
4425 else
4426 ! Upwind by wave-fan wedge: the inner zones ride the contact (u_n = S_M) and the
4427 ! tangential state switches L -> star -> R across the shear waves (zones 2 and 3
4428 ! share the tangential star state)
4429 if (zone == 0) then
4430 u_n_face = u_n_l; u_t_face = u_t_l
4431 else if (zone == 1) then
4432 u_n_face = s_m; u_t_face = u_t_l
4433 else if (zone <= 3) then
4434 u_n_face = s_m; u_t_face = u_t_star
4435 else if (zone == 4) then
4436 u_n_face = s_m; u_t_face = u_t_r
4437 else
4438 u_n_face = u_n_r; u_t_face = u_t_r
4439 end if
4440 ! ADC blend NC face velocities with HLL scalar traces (valid fans; a fallback
4441 ! face already exports the pure HLL traces)
4442 if (riemann_hypo_adc) then
4443 u_n_face = u_n_hll_trace + phi*(u_n_face - u_n_hll_trace)
4444 u_t_face = u_t_hll_trace + phi*(u_t_face - u_t_hll_trace)
4445 end if
4446 end if
4447# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4448 if (ipass == 1) then
4449 if (dir_idx(1) == 1) then
4450 nc_iface_vel_rsx_vf(j, k, l, 1) = u_n_face
4451 nc_iface_vel_rsx_vf(j, k, l, 2) = u_t_face
4452 else
4453 nc_iface_vel_rsx_vf(j, k, l, 1) = u_t_face
4454 nc_iface_vel_rsx_vf(j, k, l, 2) = u_n_face
4455 end if
4456 end if
4457# 898 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4458 if (ipass == 2) then
4459 if (dir_idx(1) == 1) then
4460 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_n_face
4461 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_t_face
4462 else
4463 nc_iface_vel_hatr_rsx_vf(j, k, l, 1) = u_t_face
4464 nc_iface_vel_hatr_rsx_vf(j, k, l, 2) = u_n_face
4465 end if
4466 end if
4467# 908 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4468 end if
4469
4470 ! Radial geometric source flux for cylindrical coordinates. Only genuinely conservative rows
4471 ! (masses, momenta, energy) carry a numerical geometric flux: their full radial flux IS the
4472 ! -H/r metric quantity. The volume-fraction and stress rows are zeroed: the augmented stress
4473 ! fluxes fold constitutive velocity terms that must not be divided by r; their complete
4474 ! cylindrical completion is the cell-local dual-pass source
4475 ! (s_compute_hypoelastic_rhs_axisym_geom_dual_pass).
4476# 959 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4477 end do
4478
4479 ! Dual-pass HLLD: all NC terms stay inside the Riemann flux (anchor-independent; written once)
4480 flux_src_rsx_vf(j, k, l, eqn_idx%adv%beg) = 0._wp
4481 end do
4482 end do
4483 end do
4484
4485# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4486#if defined(MFC_OpenACC)
4487# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4488!$acc end parallel loop
4489# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4490#elif defined(MFC_OpenMP)
4491# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4492
4493# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4494!$omp end target teams loop
4495# 966 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4496#endif
4497 end if
4498# 969 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4499
4500 call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir)
4501
4502 end subroutine s_hypo_hlld_riemann_solver
4503
4504 !> Copy the hypo interface velocities of a fused-solve pass from Riemann-space buffers to physical-space output arrays, called
4505 !! after the Riemann solver for each sweep direction. The plain routine handles the hat_L-anchored values (nc_iface_vel_rsx;
4506 !! used when hypo_nc_mode_interface is active, and as the hat_L pass of the dual-pass HLLD solve); the _hatR routine handles the
4507 !! hat_R-anchored values (nc_iface_vel_hatR_rsx) of the dual-pass solve. Both routines are emitted from one template so the two
4508 !! passes cannot drift apart.
4509 !! @param nc_iface_vel_vf Output: physical velocity components at interfaces
4510 !! @param norm_dir Sweep direction (1=x, 2=y, 3=z)
4511# 982 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4512 subroutine s_finalize_nc_iface_vel (nc_iface_vel_vf, norm_dir)
4513
4514 type(scalar_field), dimension(:), intent(inout) :: nc_iface_vel_vf
4515 integer, intent(in) :: norm_dir
4516 integer :: i, j, k, l
4517
4518 if (norm_dir == 2) then
4519
4520# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4521
4522# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4523#if defined(MFC_OpenACC)
4524# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4525!$acc parallel loop collapse(4) gang vector default(present)
4526# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4527#elif defined(MFC_OpenMP)
4528# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4529
4530# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4531
4532# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4533
4534# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4535!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4536# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4537#endif
4538 do i = 1, num_dims
4539 do l = is3%beg, is3%end
4540 do j = is1%beg, is1%end
4541 do k = is2%beg, is2%end
4542 nc_iface_vel_vf(i)%sf(k, j, l) = nc_iface_vel_rsx_vf(k, j, l, i)
4543 end do
4544 end do
4545 end do
4546 end do
4547
4548# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4549#if defined(MFC_OpenACC)
4550# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4551!$acc end parallel loop
4552# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4553#elif defined(MFC_OpenMP)
4554# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4555
4556# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4557!$omp end target teams loop
4558# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4559#endif
4560 else if (norm_dir == 1) then
4561
4562# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4563
4564# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4565#if defined(MFC_OpenACC)
4566# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4567!$acc parallel loop collapse(4) gang vector default(present)
4568# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4569#elif defined(MFC_OpenMP)
4570# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4571
4572# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4573
4574# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4575
4576# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4577!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4578# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4579#endif
4580 do i = 1, num_dims
4581 do l = is3%beg, is3%end
4582 do k = is2%beg, is2%end
4583 do j = is1%beg, is1%end
4584 nc_iface_vel_vf(i)%sf(j, k, l) = nc_iface_vel_rsx_vf(j, k, l, i)
4585 end do
4586 end do
4587 end do
4588 end do
4589
4590# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4591#if defined(MFC_OpenACC)
4592# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4593!$acc end parallel loop
4594# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4595#elif defined(MFC_OpenMP)
4596# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4597
4598# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4599!$omp end target teams loop
4600# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4601#endif
4602 else if (norm_dir == 3) then
4603
4604# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4605
4606# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4607#if defined(MFC_OpenACC)
4608# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4609!$acc parallel loop collapse(4) gang vector default(present)
4610# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4611#elif defined(MFC_OpenMP)
4612# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4613
4614# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4615
4616# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4617
4618# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4619!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4620# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4621#endif
4622 do i = 1, num_dims
4623 do l = is3%beg, is3%end
4624 do k = is2%beg, is2%end
4625 do j = is1%beg, is1%end
4626 nc_iface_vel_vf(i)%sf(l, k, j) = nc_iface_vel_rsx_vf(l, k, j, i)
4627 end do
4628 end do
4629 end do
4630 end do
4631
4632# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4633#if defined(MFC_OpenACC)
4634# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4635!$acc end parallel loop
4636# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4637#elif defined(MFC_OpenMP)
4638# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4639
4640# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4641!$omp end target teams loop
4642# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4643#endif
4644 end if
4645
4646 end subroutine s_finalize_nc_iface_vel
4647# 982 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4648 subroutine s_finalize_nc_iface_vel_hatr (nc_iface_vel_vf, norm_dir)
4649
4650 type(scalar_field), dimension(:), intent(inout) :: nc_iface_vel_vf
4651 integer, intent(in) :: norm_dir
4652 integer :: i, j, k, l
4653
4654 if (norm_dir == 2) then
4655
4656# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4657
4658# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4659#if defined(MFC_OpenACC)
4660# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4661!$acc parallel loop collapse(4) gang vector default(present)
4662# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4663#elif defined(MFC_OpenMP)
4664# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4665
4666# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4667
4668# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4669
4670# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4671!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4672# 989 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4673#endif
4674 do i = 1, num_dims
4675 do l = is3%beg, is3%end
4676 do j = is1%beg, is1%end
4677 do k = is2%beg, is2%end
4678 nc_iface_vel_vf(i)%sf(k, j, l) = nc_iface_vel_hatr_rsx_vf(k, j, l, i)
4679 end do
4680 end do
4681 end do
4682 end do
4683
4684# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4685#if defined(MFC_OpenACC)
4686# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4687!$acc end parallel loop
4688# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4689#elif defined(MFC_OpenMP)
4690# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4691
4692# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4693!$omp end target teams loop
4694# 999 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4695#endif
4696 else if (norm_dir == 1) then
4697
4698# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4699
4700# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4701#if defined(MFC_OpenACC)
4702# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4703!$acc parallel loop collapse(4) gang vector default(present)
4704# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4705#elif defined(MFC_OpenMP)
4706# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4707
4708# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4709
4710# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4711
4712# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4713!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4714# 1001 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4715#endif
4716 do i = 1, num_dims
4717 do l = is3%beg, is3%end
4718 do k = is2%beg, is2%end
4719 do j = is1%beg, is1%end
4720 nc_iface_vel_vf(i)%sf(j, k, l) = nc_iface_vel_hatr_rsx_vf(j, k, l, i)
4721 end do
4722 end do
4723 end do
4724 end do
4725
4726# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4727#if defined(MFC_OpenACC)
4728# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4729!$acc end parallel loop
4730# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4731#elif defined(MFC_OpenMP)
4732# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4733
4734# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4735!$omp end target teams loop
4736# 1011 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4737#endif
4738 else if (norm_dir == 3) then
4739
4740# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4741
4742# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4743#if defined(MFC_OpenACC)
4744# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4745!$acc parallel loop collapse(4) gang vector default(present)
4746# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4747#elif defined(MFC_OpenMP)
4748# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4749
4750# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4751
4752# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4753
4754# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4755!$omp target teams loop defaultmap(firstprivate:scalar) bind(teams,parallel) collapse(4) defaultmap(tofrom:aggregate) defaultmap(tofrom:allocatable) defaultmap(tofrom:pointer)
4756# 1013 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4757#endif
4758 do i = 1, num_dims
4759 do l = is3%beg, is3%end
4760 do k = is2%beg, is2%end
4761 do j = is1%beg, is1%end
4762 nc_iface_vel_vf(i)%sf(l, k, j) = nc_iface_vel_hatr_rsx_vf(l, k, j, i)
4763 end do
4764 end do
4765 end do
4766 end do
4767
4768# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4769#if defined(MFC_OpenACC)
4770# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4771!$acc end parallel loop
4772# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4773#elif defined(MFC_OpenMP)
4774# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4775
4776# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4777!$omp end target teams loop
4778# 1023 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4779#endif
4780 end if
4781
4782 end subroutine s_finalize_nc_iface_vel_hatr
4783# 1028 "/home/runner/work/MFC/MFC/src/simulation/m_riemann_solver_hypo_hlld.fpp"
4784end module m_riemann_solver_hypo_hlld
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 computational domain, fluid properties, and simulation algorithm configurat...
Definition m_global_parameters.fpp.f90:334
m_global_parameters::grid_geometry
integer grid_geometry
Definition m_global_parameters.fpp.f90:377
m_global_parameters::dir_idx
integer, dimension(3) dir_idx
Definition m_global_parameters.fpp.f90:744
m_global_parameters::stress_perm
integer, dimension(6) stress_perm
Full tensor permutation: local basis -> physical storage index.
Definition m_global_parameters.fpp.f90:747
m_riemann_solver_hypo_hlld
Dual-pass HLLD approximate Riemann solver for hypoelastic flows, with non-conservative interface-velo...
Definition m_riemann_solver_hypo_hlld.fpp.f90:352
m_riemann_solver_hypo_hlld::s_finalize_nc_iface_vel_hatr
subroutine s_finalize_nc_iface_vel_hatr(nc_iface_vel_vf, norm_dir)
Definition m_riemann_solver_hypo_hlld.fpp.f90:4649
m_riemann_solver_hypo_hlld::s_finalize_nc_iface_vel
subroutine s_finalize_nc_iface_vel(nc_iface_vel_vf, norm_dir)
Copy the hypo interface velocities of a fused-solve pass from Riemann-space buffers to physical-space...
Definition m_riemann_solver_hypo_hlld.fpp.f90:4513
m_riemann_solver_hypo_hlld::f_hlld_wave_zone
integer function f_hlld_wave_zone(s_l, s_lstar, s_m, s_rstar, s_r)
Classify the position of the interface (xi = 0) in the five-wave HLLD fan: 0 left of S_L,...
Definition m_riemann_solver_hypo_hlld.fpp.f90:372
m_riemann_solver_hypo_hlld::g_eff_roundoff_factor
real(wp), parameter g_eff_roundoff_factor
Four-epsilon roundoff band for G_eff: two mixture products, their sum, and the final signed sum....
Definition m_riemann_solver_hypo_hlld.fpp.f90:363
m_riemann_solver_hypo_hlld::s_hypo_hlld_riemann_solver
subroutine s_hypo_hlld_riemann_solver(ql_prim_rsx_vf, dql_prim_dx_vf, dql_prim_dy_vf, dql_prim_dz_vf, ql_prim_vf, qr_prim_rsx_vf, dqr_prim_dx_vf, dqr_prim_dy_vf, dqr_prim_dz_vf, qr_prim_vf, q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz)
HLLD Riemann solver resolves all 5 waves for the hypoelastic equations: 1 entropy wave,...
Definition m_riemann_solver_hypo_hlld.fpp.f90:430
m_riemann_state
Shared Riemann-solver module state and the per-sweep setup, state-buffer population,...
Definition m_riemann_state.fpp.f90:335
m_riemann_state::flux_src_rsx_vf
real(wp), dimension(:,:,:,:), allocatable flux_src_rsx_vf
Definition m_riemann_state.fpp.f90:348
m_riemann_state::is3
type(int_bounds_info) is3
Definition m_riemann_state.fpp.f90:477
m_riemann_state::flux_rsx_vf
real(wp), dimension(:,:,:,:), allocatable flux_rsx_vf
The cell-boundary values of the fluxes (src - source) that are computed through the chosen Riemann pr...
Definition m_riemann_state.fpp.f90:348
m_riemann_state::s_initialize_riemann_solver
subroutine s_initialize_riemann_solver(flux_src_vf, norm_dir)
Set up the chosen Riemann solver algorithm for the current direction.
Definition m_riemann_state.fpp.f90:1630
m_riemann_state::nc_iface_vel_rsx_vf
real(wp), dimension(:,:,:,:), allocatable nc_iface_vel_rsx_vf
Definition m_riemann_state.fpp.f90:378
m_riemann_state::gs_rs
real(wp), dimension(:), allocatable gs_rs
Definition m_riemann_state.fpp.f90:493
m_riemann_state::s_populate_riemann_states_variables_buffers
subroutine s_populate_riemann_states_variables_buffers(ql_prim_rsx_vf, dql_prim_dx_vf, dql_prim_dy_vf, dql_prim_dz_vf, qr_prim_rsx_vf, dqr_prim_dx_vf, dqr_prim_dy_vf, dqr_prim_dz_vf, norm_dir, ix, iy, iz)
Populate the left and right Riemann state variable buffers based on boundary conditions.
Definition m_riemann_state.fpp.f90:548
m_riemann_state::is2
type(int_bounds_info) is2
Definition m_riemann_state.fpp.f90:477
m_riemann_state::s_finalize_riemann_solver
subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir)
Reshape and copy the Riemann-solver flux buffers back to the physical-space output arrays for the sel...
Definition m_riemann_state.fpp.f90:2923
m_riemann_state::flux_hatr_rsx_vf
real(wp), dimension(:,:,:,:), allocatable flux_hatr_rsx_vf
Dual-pass HLLD second flux set: the hat_R-anchored fluxes (and, for axisymmetric runs,...
Definition m_riemann_state.fpp.f90:394
m_riemann_state::flux_gsrc_rsx_vf
real(wp), dimension(:,:,:,:), allocatable flux_gsrc_rsx_vf
The cell-boundary values of the geometrical source flux that are computed through the chosen Riemann ...
Definition m_riemann_state.fpp.f90:365
m_riemann_state::nc_iface_vel_hatr_rsx_vf
real(wp), dimension(:,:,:,:), allocatable nc_iface_vel_hatr_rsx_vf
Definition m_riemann_state.fpp.f90:407
m_riemann_state::flux_gsrc_hatr_rsx_vf
real(wp), dimension(:,:,:,:), allocatable flux_gsrc_hatr_rsx_vf
Definition m_riemann_state.fpp.f90:420
m_riemann_state::is1
type(int_bounds_info) is1
Definition m_riemann_state.fpp.f90:477
m_variables_conversion
Conservative-to-primitive variable conversion, mixture property evaluation, and pressure computation.
Definition m_variables_conversion.fpp.f90:334
m_variables_conversion::s_compute_speed_of_sound
subroutine, public s_compute_speed_of_sound(pres, rho, gamma, pi_inf, h, adv, vel_sum, c_c, c, qv)
Compute the speed of sound from thermodynamic state variables, supporting multiple equation-of-state ...
Definition m_variables_conversion.fpp.f90:2530
m_derived_types::int_bounds_info
Integer bounds for variables.
Definition m_derived_types.fpp.f90:417
m_derived_types::riemann_states_vec3
Left and right Riemann states for 3-component vectors.
Definition m_derived_types.fpp.f90:405
m_derived_types::riemann_states
Left and right Riemann states.
Definition m_derived_types.fpp.f90:399
m_derived_types::scalar_field
Derived type annexing a scalar field (SF).
Definition m_derived_types.fpp.f90:337