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