From c4207e2bf0cfb9f62ef46336a1b1d65176e64b30 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Sun, 1 Jun 2025 21:10:04 -0400 Subject: [PATCH 01/58] added s_compute_wave_speed --- src/common/m_variables_conversion.fpp | 100 ++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 9cac8081f..5faa0b4c7 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -44,6 +44,7 @@ module m_variables_conversion #ifndef MFC_PRE_PROCESS s_compute_speed_of_sound, & s_compute_fast_magnetosonic_speed, & + s_compute_wave_speed, & #endif s_finalize_variables_conversion_module @@ -1719,4 +1720,103 @@ contains end subroutine s_compute_fast_magnetosonic_speed #endif +#ifndef MFC_PRE_PROCESS + subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S) + + ! Computes the wave speeds for the Riemann solver +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_wave_speed +#else + !$acc routine seq +#endif + + ! Input parameters + integer, intent(in) :: wave_speeds + real(wp), intent(in) :: rho_L, rho_R + real(wp), dimension(:), intent(in) :: vel_L, vel_R + real(wp), intent(in) :: pres_L, pres_R, c_L, c_R + real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R + real(wp), intent(in) :: rho_avg, c_avg, c_fast + real(wp), intent(in) :: G_L, G_R + real(wp), dimension(:), intent(in) :: tau_e_L, tau_e_R + + ! Local variables + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + + ! Output parameters + real(wp), intent(out) :: s_L, s_R, s_S + + if (wave_speeds == 1) then + if (mhd) then + s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) + s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) + elseif (hypoelasticity .or. elasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + else if (hyperelasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + else + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + end if + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & + (s_L - vel_L(dir_idx(1))) - & + rho_R*vel_R(dir_idx(1))* & + (s_R - vel_R(dir_idx(1)))) & + /(rho_L*(s_L - vel_L(dir_idx(1))) - & + rho_R*(s_R - vel_R(dir_idx(1)))) + elseif (wave_speeds == 2) then + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & + (vel_L(dir_idx(1)) - & + vel_R(dir_idx(1)))) + pres_SR = pres_SL + Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & + (pres_SL/pres_L - 1._wp)*pres_L/ & + ((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & + (pres_L - pres_R)/ & + (rho_avg*c_avg)) + end if + +#ifdef DEBUG + ! Check for potential issues in wave speed calculation + if (s_R <= s_L) then + print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' + print *, 'Left wave speed >= Right wave speed:', s_L, s_R + print *, 'Input velocities (dir_idx(1)):', vel_L(dir_idx(1)), vel_R(dir_idx(1)) + print *, 'Sound speeds:', c_L, c_R + print *, 'Densities:', rho_L, rho_R + print *, 'Pressures:', pres_L, pres_R + print *, 'Wave speeds method:', wave_speeds + if (elasticity .or. hypoelasticity .or. hyperelasticity) then + print *, 'Shear moduli:', G_L, G_R + end if + call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') + end if +#endif + + end subroutine s_compute_wave_speed +#endif + end module m_variables_conversion From fcc7ed593dd53479df3f8073a78b4f2380be1f40 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Sun, 1 Jun 2025 21:29:04 -0400 Subject: [PATCH 02/58] implemented s_compute_wave_speed on all solvers --- src/common/m_variables_conversion.fpp | 8 +- src/simulation/m_riemann_solvers.fpp | 236 +++----------------------- 2 files changed, 26 insertions(+), 218 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 5faa0b4c7..3ebcac12c 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1724,7 +1724,7 @@ contains subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & c_L, c_R, c_avg, c_fast, G_L, G_R, & tau_e_L, tau_e_R, & - s_L, s_R, s_S) + s_L, s_R, s_S, s_M, s_P) ! Computes the wave speeds for the Riemann solver #ifdef _CRAYFTN @@ -1747,7 +1747,7 @@ contains real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R ! Output parameters - real(wp), intent(out) :: s_L, s_R, s_S + real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P if (wave_speeds == 1) then if (mhd) then @@ -1799,6 +1799,10 @@ contains (rho_avg*c_avg)) end if + ! follows Einfeldt et al. + ! s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + #ifdef DEBUG ! Check for potential issues in wave speed calculation if (s_R <= s_L) then diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 8dcd4e808..2bda4153a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -687,62 +687,10 @@ contains end do end if - if (wave_speeds == 1) then - if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) - s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) - elseif (hypoelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L)) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - end if - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -1497,51 +1445,10 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - if (wave_speeds == 1) then - if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(idx1)*(s_L - vel_L(idx1)) - & - rho_R*vel_R(idx1)*(s_R - vel_R(idx1)))/(rho_L*(s_L - vel_L(idx1)) - & - rho_R*(s_R - vel_R(idx1))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - - end if - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1807,41 +1714,10 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - if (wave_speeds == 1) then - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2236,41 +2112,10 @@ contains @:compute_low_Mach_correction() end if - if (wave_speeds == 1) then - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2705,51 +2550,10 @@ contains @:compute_low_Mach_correction() end if - if (wave_speeds == 1) then - if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(idx1)*(s_L - vel_L(idx1)) - & - rho_R*vel_R(idx1)*(s_R - vel_R(idx1)))/(rho_L*(s_L - vel_L(idx1)) - & - rho_R*(s_R - vel_R(idx1))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - - end if - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(idx1) - & - vel_R(idx1))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(idx1) - c_L*Ms_L - s_R = vel_R(idx1) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(idx1) + vel_R(idx1)) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From 62ffeee1ae6816c798f77db7d18aabcf6cac4ef7 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Sun, 1 Jun 2025 22:29:08 -0400 Subject: [PATCH 03/58] cleaned up s_hlld_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 144 +++++++++++---------------- 1 file changed, 60 insertions(+), 84 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 2bda4153a..532cfcd59 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2849,7 +2849,7 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - + real ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2859,6 +2859,50 @@ contains real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double integer :: i, j, k, l + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho, U(2) = rho*vel(1), U(3) = rho*vel(2), U(4) = rho*vel(3) + U(5) = B(2), U(6) = B(3), U(7) = E + ! Compute the flux vector + F(1) = U(2), F(2) = U(2)*vel(1) - B(1)*B(1) + pTot, F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3), F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1), F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star, U_star(2) = rho_star*s_M, U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3), U_star(5) = B(2), U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -2969,74 +3013,15 @@ contains E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - ! (5) Compute the left/right conserved state vectors - U_L(1) = rho%L - U_L(2) = rho%L*vel%L(1) - U_L(3) = rho%L*vel%L(2) - U_L(4) = rho%L*vel%L(3) - U_L(5) = B%L(2) - U_L(6) = B%L(3) - U_L(7) = E%L - - U_R(1) = rho%R - U_R(2) = rho%R*vel%R(1) - U_R(3) = rho%R*vel%R(2) - U_R(4) = rho%R*vel%R(3) - U_R(5) = B%R(2) - U_R(6) = B%R(3) - U_R(7) = E%R - - ! (6) Compute the left/right star state vectors - U_starL(1) = rhoL_star - U_starL(2) = rhoL_star*s_M - U_starL(3) = rhoL_star*vel%L(2) - U_starL(4) = rhoL_star*vel%L(3) - U_starL(5) = B%L(2) - U_starL(6) = B%L(3) - U_starL(7) = E_starL - - U_starR(1) = rhoR_star - U_starR(2) = rhoR_star*s_M - U_starR(3) = rhoR_star*vel%R(2) - U_starR(4) = rhoR_star*vel%R(3) - U_starR(5) = B%R(2) - U_starR(6) = B%R(3) - U_starR(7) = E_starR - - ! (7) Compute the left/right fluxes - F_L(1) = rho%L*vel%L(1) - F_L(2) = rho%L*vel%L(1)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3) = rho%L*vel%L(1)*vel%L(2) - B%L(1)*B%L(2) - F_L(4) = rho%L*vel%L(1)*vel%L(3) - B%L(1)*B%L(3) - F_L(5) = vel%L(1)*B%L(2) - vel%L(2)*B%L(1) - F_L(6) = vel%L(1)*B%L(3) - vel%L(3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) - - F_R(1) = rho%R*vel%R(1) - F_R(2) = rho%R*vel%R(1)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3) = rho%R*vel%R(1)*vel%R(2) - B%R(1)*B%R(2) - F_R(4) = rho%R*vel%R(1)*vel%R(3) - B%R(1)*B%R(3) - F_R(5) = vel%R(1)*B%R(2) - vel%R(2)*B%R(1) - F_R(6) = vel%R(1)*B%R(3) - vel%R(3)*B%R(1) - F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - - ! (8) Compute the left/right star fluxes (note array operations) - F_starL = F_L + s_L*(U_starL - U_L) - F_starR = F_R + s_R*(U_starR - U_R) - - ! (9) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! (5) Compute left/right state vectors and fluxes + call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) - ! (10) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - sqrt_rhoL_star = sqrt(rhoL_star) - sqrt_rhoR_star = sqrt(rhoR_star) + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star sign_Bx = sign(1._wp, B%L(1)) - vL_star = vel%L(2) - wL_star = vel%L(3) - vR_star = vel%R(2) - wR_star = vel%R(3) v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds @@ -3046,23 +3031,14 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL(1) = rhoL_star - U_doubleL(2) = rhoL_star*s_M - U_doubleL(3) = rhoL_star*v_double - U_doubleL(4) = rhoL_star*w_double - U_doubleL(5) = By_double - U_doubleL(6) = Bz_double - U_doubleL(7) = E_double - - U_doubleR(1) = rhoR_star - U_doubleR(2) = rhoR_star*s_M - U_doubleR(3) = rhoR_star*v_double - U_doubleR(4) = rhoR_star*w_double - U_doubleR(5) = By_double - U_doubleR(6) = Bz_double - U_doubleR(7) = E_double - - ! (11) Choose HLLD flux based on wave-speed regions + U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -3077,7 +3053,7 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array + ! (9) Reorder and write temporary variables to the flux array ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum From 4290728bf9de4d35e836306cee31b63704a1eb54 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 01:30:38 -0400 Subject: [PATCH 04/58] cleaned up s_hllc_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 572 +++++++++------------------ 1 file changed, 197 insertions(+), 375 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 532cfcd59..e38bfcfab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1213,6 +1213,78 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux + ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -1289,15 +1361,6 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) @@ -1305,6 +1368,7 @@ contains !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -1329,91 +1393,75 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - + Re_R(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0._wp - + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -1595,40 +1643,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -1694,7 +1709,6 @@ contains end do E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L @@ -1782,7 +1796,6 @@ contains ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do @@ -1802,53 +1815,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -1884,6 +1851,10 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then @@ -1893,30 +1864,6 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else - rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - end if - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) @@ -1925,12 +1872,20 @@ contains else if (num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) end do else + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) @@ -1942,38 +1897,25 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L @@ -2237,54 +2179,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -2341,22 +2236,13 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2378,31 +2264,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -2459,67 +2333,63 @@ contains H_R = (E_R + pres_R)/rho_R else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R end if - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -2706,55 +2576,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & - xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - + xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - - xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif - + call s_compute_cylindrical_geometry_source_flux() end do end do end do From 947f203fe8a7369a4bf9cb5d997a51d597760ebc Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 02:27:42 -0400 Subject: [PATCH 05/58] cleaned up s_hll_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 327 ++++++++++----------------- 1 file changed, 118 insertions(+), 209 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e38bfcfab..cc19ea4ab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -474,31 +474,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -512,13 +500,11 @@ contains call get_mixture_molecular_weight(Ys_L, MW_L) call get_mixture_molecular_weight(Ys_R, MW_R) - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) R_gas_L = gas_constant/MW_L R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L T_R = pres_R/rho_R/R_gas_R @@ -552,44 +538,39 @@ contains E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R - elseif (mhd .and. relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L - b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R - b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R - b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - - cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) - cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) - cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) - cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) - cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) - cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (mhd .and. .not. relativity) then - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + elseif (mhd) then + if (relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = dot_product(vel%L, B%L) + vdotB%R = dot_product(vel%R, B%R) + !acc loop seq + do i = 1, 3 + b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L + b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + end do + B2%L = sum(B%L**2._wp) + B2%R = sum(B%R**2._wp) + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + !acc loop seq + do i = 1, 3 + cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) + cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) + end do + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (.not. relativity) then + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + end if else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R @@ -729,75 +710,52 @@ contains end do end if - ! Momentum - if (mhd .and. (.not. relativity)) then - ! Flux of rho*v_x in the ${XYZ}$ direction - ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & - - B%R(1)*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & - - B%L(1)*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & - /(s_M - s_P) - ! Flux of rho*v_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & - - B%R(2)*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & - - B%L(2)*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & - /(s_M - s_P) - ! Flux of rho*v_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & - - B%R(3)*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & - - B%L(3)*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! Flux of m_x in the ${XYZ}$ direction - ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(cm%R(1)*vel_R(norm_dir) & - - b4%R(1)/Ga%R*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(1)*vel_L(norm_dir) & - - b4%L(1)/Ga%L*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(1) - cm%R(1))) & - /(s_M - s_P) - ! Flux of m_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(cm%R(2)*vel_R(norm_dir) & - - b4%R(2)/Ga%R*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(2)*vel_L(norm_dir) & - - b4%L(2)/Ga%L*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(2) - cm%R(2))) & - /(s_M - s_P) - ! Flux of m_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(cm%R(3)*vel_R(norm_dir) & - - b4%R(3)/Ga%R*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(3)*vel_L(norm_dir) & - - b4%L(3)/Ga%L*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(3) - cm%R(3))) & - /(s_M - s_P) + ! Momentum and Energy fluxes + if (mhd) then + if (.not. relativity) then + ! Flux of rho*v_x in the ${XYZ}$ direction + ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + !acc loop seq + do i = 1, 3 + flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & + (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & + - B%R(i)*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + - B%L(i)*B%L(norm_dir) & + + dir_flg(i)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & + /(s_M - s_P) + end do + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + + elseif (relativity) then + do i = 1, 3 + ! Flux of m_x in the ${XYZ}$ direction + ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & + (s_M*(cm%R(i)*vel_R(norm_dir) & + - b4%R(i)/Ga%R*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(i)*vel_L(norm_dir) & + - b4%L(i)/Ga%L*B%L(norm_dir) & + + dir_flg(i)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(i) - cm%R(i))) & + /(s_M - s_P) + end do + ! energy flux = m_${XYZ}$ - mass flux + ! Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + end if elseif (bubbles_euler) then !$acc loop seq do i = 1, num_vels @@ -813,6 +771,13 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do + ! energy flux + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then !$acc loop seq do i = 1, num_vels @@ -829,6 +794,18 @@ contains - rho_R*vel_R(dir_idx(i)))) & /(s_M - s_P) end do + ! energy flux + real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp + !acc loop seq + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) else !$acc loop seq do i = 1, num_vels @@ -844,65 +821,7 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do - end if - - ! Energy - if (mhd .and. (.not. relativity)) then - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - !TODO: simplify this so it's not split into 3 - if (num_dims == 1) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 2) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 3) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & - - (tau_e_R(dir_idx_tau(3))*vel_R(dir_idx(3)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2))) & - - (tau_e_L(dir_idx_tau(3))*vel_L(dir_idx(3)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - end if - else + ! energy flux flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & @@ -988,34 +907,25 @@ contains if (mhd) then if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. ! B_y flux = v_x * B_y - v_y * Bx0 - flux_rsx_vf(j, k, l, B_idx%beg) = (s_M*(vel_R(1)*B%R(2) - vel_R(2)*Bx0) & - - s_P*(vel_L(1)*B%L(2) - vel_L(2)*Bx0) + s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) - ! B_z flux = v_x * B_z - v_z * Bx0 - flux_rsx_vf(j, k, l, B_idx%beg + 1) = (s_M*(vel_R(1)*B%R(3) - vel_R(3)*Bx0) & - - s_P*(vel_L(1)*B%L(3) - vel_L(3)*Bx0) + s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) - + !acc loop seq + do i = 0, 1 + flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & + + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = (1 - dir_flg(1))*( & - s_M*(vel_R(dir_idx(1))*B%R(1) - vel_R(1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(1) - vel_L(1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(1) - B%R(1)))/(s_M - s_P) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = (1 - dir_flg(2))*( & - s_M*(vel_R(dir_idx(1))*B%R(2) - vel_R(2)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(2) - vel_L(2)*B%L(norm_dir)) + & - s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) = (1 - dir_flg(3))*( & - s_M*(vel_R(dir_idx(1))*B%R(3) - vel_R(3)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(3) - vel_L(3)*B%L(norm_dir)) + & - s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) - + !$acc loop seq + do i = 0, 2 + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & + s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + end do end if - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp end if @@ -1050,7 +960,6 @@ contains end do end if #:endif - end do end do end do From fede1c15cfd0050daf0d95e6a9645b4fe954a516 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 12:41:00 -0400 Subject: [PATCH 06/58] fixed s_compute_wave_speed subroutine --- src/common/m_variables_conversion.fpp | 10 +++++----- src/simulation/m_riemann_solvers.fpp | 20 ++++++++++---------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 3ebcac12c..84b5f7615 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1721,8 +1721,8 @@ contains #endif #ifndef MFC_PRE_PROCESS - subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) @@ -1739,7 +1739,7 @@ contains real(wp), dimension(:), intent(in) :: vel_L, vel_R real(wp), intent(in) :: pres_L, pres_R, c_L, c_R real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R - real(wp), intent(in) :: rho_avg, c_avg, c_fast + real(wp), intent(in) :: rho_avg, c_avg, c_fast_L, c_fast_R real(wp), intent(in) :: G_L, G_R real(wp), dimension(:), intent(in) :: tau_e_L, tau_e_R @@ -1751,8 +1751,8 @@ contains if (wave_speeds == 1) then if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) - s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) + s_L = min(vel_L(dir_idx(1)) - c_fast_L, vel_R(dir_idx(1)) - c_fast_R) + s_R = max(vel_R(dir_idx(1)) + c_fast_R, vel_L(dir_idx(1)) + c_fast_L) elseif (hypoelasticity .or. elasticity) then s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & (((4._wp*G_L)/3._wp) + & diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index cc19ea4ab..627665ac5 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,8 +668,8 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S) @@ -1402,8 +1402,8 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S) @@ -1637,8 +1637,8 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) @@ -1963,8 +1963,8 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) @@ -2329,8 +2329,8 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) From ee64da0ab128c655db59a9fbb4b0b0f13146b254 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 13:03:57 -0400 Subject: [PATCH 07/58] removed dir_idx indexing from the definition of wave speed subroutine --- src/common/m_variables_conversion.fpp | 56 +++++++++++++-------------- src/simulation/m_riemann_solvers.fpp | 26 ++++++------- 2 files changed, 41 insertions(+), 41 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 84b5f7615..80622fd59 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1751,40 +1751,40 @@ contains if (wave_speeds == 1) then if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast_L, vel_R(dir_idx(1)) - c_fast_R) - s_R = max(vel_R(dir_idx(1)) + c_fast_R, vel_L(dir_idx(1)) + c_fast_L) + s_L = min(vel_L - c_fast_L, vel_R - c_fast_R) + s_R = max(vel_R + c_fast_R, vel_L + c_fast_L) elseif (hypoelasticity .or. elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & + s_L = min(vel_L - sqrt(c_L*c_L + & (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + tau_e_L)/rho_L) & + , vel_R - sqrt(c_R*c_R + & (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & + tau_e_R)/rho_R)) + s_R = max(vel_R + sqrt(c_R*c_R + & (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + tau_e_R)/rho_R) & + , vel_L + sqrt(c_L*c_L + & (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) + tau_e_L)/rho_L)) else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_L = min(vel_L - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + s_L = min(vel_L - c_L, vel_R - c_R) + s_R = max(vel_R + c_R, vel_L + c_L) end if - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) + s_S = (pres_R - pres_L + rho_L*vel_L* & + (s_L - vel_L) - & + rho_R*vel_R* & + (s_R - vel_R)) & + /(rho_L*(s_L - vel_L) - & + rho_R*(s_R - vel_R)) elseif (wave_speeds == 2) then pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) + (vel_L - & + vel_R)) pres_SR = pres_SL Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & (pres_SL/pres_L - 1._wp)*pres_L/ & @@ -1792,9 +1792,9 @@ contains Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & (pres_SR/pres_R - 1._wp)*pres_R/ & ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & + s_L = vel_L - c_L*Ms_L + s_R = vel_R + c_R*Ms_R + s_S = 5e-1_wp*((vel_L + vel_R) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if @@ -1808,7 +1808,7 @@ contains if (s_R <= s_L) then print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' print *, 'Left wave speed >= Right wave speed:', s_L, s_R - print *, 'Input velocities (dir_idx(1)):', vel_L(dir_idx(1)), vel_R(dir_idx(1)) + print *, 'Input velocities :', vel_L, vel_R print *, 'Sound speeds:', c_L, c_R print *, 'Densities:', rho_L, rho_R print *, 'Pressures:', pres_L, pres_R diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 627665ac5..fe906513a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,9 +668,9 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & @@ -1402,9 +1402,9 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1637,10 +1637,10 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1963,10 +1963,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2329,10 +2329,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From 7313eba43927c81c471dde70982044b99bc4cc70 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 14:37:41 -0400 Subject: [PATCH 08/58] dir_idx re-added --- src/common/m_variables_conversion.fpp | 64 +++++++++++---------------- src/simulation/m_riemann_solvers.fpp | 20 ++++----- 2 files changed, 36 insertions(+), 48 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 80622fd59..6ee9aac52 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1736,12 +1736,11 @@ contains ! Input parameters integer, intent(in) :: wave_speeds real(wp), intent(in) :: rho_L, rho_R - real(wp), dimension(:), intent(in) :: vel_L, vel_R + real(wp), dimension (:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R real(wp), intent(in) :: pres_L, pres_R, c_L, c_R real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R real(wp), intent(in) :: rho_avg, c_avg, c_fast_L, c_fast_R real(wp), intent(in) :: G_L, G_R - real(wp), dimension(:), intent(in) :: tau_e_L, tau_e_R ! Local variables real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R @@ -1751,40 +1750,31 @@ contains if (wave_speeds == 1) then if (mhd) then - s_L = min(vel_L - c_fast_L, vel_R - c_fast_R) - s_R = max(vel_R + c_fast_R, vel_L + c_fast_L) + s_L = min(vel_L(dir_idx(1)) - c_fast_L, vel_R(dir_idx(1)) - c_fast_R) + s_R = max(vel_R(dir_idx(1)) + c_fast_R, vel_L(dir_idx(1)) + c_fast_L) elseif (hypoelasticity .or. elasticity) then - s_L = min(vel_L - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L)/rho_L) & - , vel_R - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R)/rho_R)) - s_R = max(vel_R + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R)/rho_R) & - , vel_L + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L)/rho_L)) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L)) else if (hyperelasticity) then - s_L = min(vel_L - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) else - s_L = min(vel_L - c_L, vel_R - c_R) - s_R = max(vel_R + c_R, vel_L + c_L) + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) end if - s_S = (pres_R - pres_L + rho_L*vel_L* & - (s_L - vel_L) - & - rho_R*vel_R* & - (s_R - vel_R)) & - /(rho_L*(s_L - vel_L) - & - rho_R*(s_R - vel_R)) + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & + (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & + /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L - & - vel_R)) + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* (vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) pres_SR = pres_SL Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & (pres_SL/pres_L - 1._wp)*pres_L/ & @@ -1792,23 +1782,21 @@ contains Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & (pres_SR/pres_R - 1._wp)*pres_R/ & ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - s_L = vel_L - c_L*Ms_L - s_R = vel_R + c_R*Ms_R - s_S = 5e-1_wp*((vel_L + vel_R) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) end if ! follows Einfeldt et al. ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + s_M = min(0._wp, s_L), s_P = max(0._wp, s_R) #ifdef DEBUG ! Check for potential issues in wave speed calculation if (s_R <= s_L) then print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' print *, 'Left wave speed >= Right wave speed:', s_L, s_R - print *, 'Input velocities :', vel_L, vel_R + print *, 'Input velocities :', vel_L(dir_idx(1)), vel_R(dir_idx(1)) print *, 'Sound speeds:', c_L, c_R print *, 'Densities:', rho_L, rho_R print *, 'Pressures:', pres_L, pres_R diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index fe906513a..16c568351 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,9 +668,9 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & @@ -1402,9 +1402,9 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1637,9 +1637,9 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1963,9 +1963,9 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -2329,9 +2329,9 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) From ea782313ccededdd32b1672523572f17114acdd8 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 16:59:20 -0400 Subject: [PATCH 09/58] fixed syntax errors --- src/common/m_variables_conversion.fpp | 12 +- src/simulation/m_riemann_solvers.fpp | 292 ++++++++++++++------------ 2 files changed, 161 insertions(+), 143 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 6ee9aac52..283f0af48 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1723,7 +1723,7 @@ contains #ifndef MFC_PRE_PROCESS subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & - tau_e_L, tau_e_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & s_L, s_R, s_S, s_M, s_P) ! Computes the wave speeds for the Riemann solver @@ -1736,10 +1736,11 @@ contains ! Input parameters integer, intent(in) :: wave_speeds real(wp), intent(in) :: rho_L, rho_R - real(wp), dimension (:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R + real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R real(wp), intent(in) :: pres_L, pres_R, c_L, c_R real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R - real(wp), intent(in) :: rho_avg, c_avg, c_fast_L, c_fast_R + real(wp), intent(in) :: rho_avg, c_avg + real(wp), intent(in) :: c_fast_L, c_fast_R real(wp), intent(in) :: G_L, G_R ! Local variables @@ -1787,9 +1788,10 @@ contains s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) end if - ! follows Einfeldt et al. + ! ! follows Einfeldt et al. ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L), s_P = max(0._wp, s_R) + s_M = min(0._wp, s_L) + s_P = max(0._wp, s_R) #ifdef DEBUG ! Check for potential issues in wave speed calculation diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 16c568351..9bce3682d 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -284,6 +284,7 @@ contains type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -330,7 +331,7 @@ contains real(wp) :: alpha_L_sum, alpha_R_sum real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag + type(riemann_states) :: c_fast, pres_mag, vel type(riemann_states_vec3) :: B type(riemann_states) :: Ga ! Gamma (Lorentz factor) @@ -542,13 +543,15 @@ contains if (relativity) then Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = dot_product(vel%L, B%L) - vdotB%R = dot_product(vel%R, B%R) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + !acc loop seq do i = 1, 3 - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L + b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R end do + B2%L = sum(B%L**2._wp) B2%R = sum(B%R**2._wp) pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) @@ -670,8 +673,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -795,7 +798,6 @@ contains /(s_M - s_P) end do ! energy flux - real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp !acc loop seq do i = 1, num_dims flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) @@ -1121,81 +1123,7 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi - - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions + type(riemann_states) :: c_fast, vel call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -1321,7 +1249,7 @@ contains E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) + if (hypoelasticity .or. hyperelasticity) then G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids @@ -1404,8 +1332,8 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1639,8 +1567,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1965,8 +1893,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2249,7 +2177,7 @@ contains end if ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) + if (hypoelasticity .or. hyperelasticity) then G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids @@ -2331,8 +2259,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2534,6 +2462,80 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux + ! end contains + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions end subroutine s_hllc_riemann_solver @@ -2580,7 +2582,6 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - real ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2590,50 +2591,6 @@ contains real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double integer :: i, j, k, l - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho, U(2) = rho*vel(1), U(3) = rho*vel(2), U(4) = rho*vel(3) - U(5) = B(2), U(6) = B(3), U(7) = E - ! Compute the flux vector - F(1) = U(2), F(2) = U(2)*vel(1) - B(1)*B(1) + pTot, F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3), F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1), F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star, U_star(2) = rho_star*s_M, U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3), U_star(5) = B(2), U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -2817,6 +2774,65 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) + + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables + ! end contains end subroutine s_hlld_riemann_solver !> The computation of parameters, the allocation of memory, From 93a408e04daa6c6c174674aa35f357376b4333fd Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 22:35:50 -0400 Subject: [PATCH 10/58] dir_idx(_tau) not recognized yet albeit global variables thus just passed them in the calls --- src/common/m_variables_conversion.fpp | 51 ++++++++++++++------------- src/simulation/m_riemann_solvers.fpp | 10 +++--- 2 files changed, 31 insertions(+), 30 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 283f0af48..879e4ecdd 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1724,7 +1724,7 @@ contains subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, idx, idx_tau) ! Computes the wave speeds for the Riemann solver #ifdef _CRAYFTN @@ -1735,6 +1735,7 @@ contains ! Input parameters integer, intent(in) :: wave_speeds + integer, intent(in) :: idx, idx_tau real(wp), intent(in) :: rho_L, rho_R real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R real(wp), intent(in) :: pres_L, pres_R, c_L, c_R @@ -1751,31 +1752,31 @@ contains if (wave_speeds == 1) then if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast_L, vel_R(dir_idx(1)) - c_fast_R) - s_R = max(vel_R(dir_idx(1)) + c_fast_R, vel_L(dir_idx(1)) + c_fast_L) + s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) + s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) elseif (hypoelasticity .or. elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) + s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) end if - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* (vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* (vel_L(idx) - vel_R(idx))) pres_SR = pres_SL Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & (pres_SL/pres_L - 1._wp)*pres_L/ & @@ -1783,9 +1784,9 @@ contains Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & (pres_SR/pres_R - 1._wp)*pres_R/ & ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + s_L = vel_L(idx) - c_L*Ms_L + s_R = vel_R(idx) + c_R*Ms_R + s_S = 5e-1_wp*((vel_L(idx) + vel_R(idx)) + (pres_L - pres_R)/(rho_avg*c_avg)) end if ! ! follows Einfeldt et al. @@ -1798,7 +1799,7 @@ contains if (s_R <= s_L) then print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' print *, 'Left wave speed >= Right wave speed:', s_L, s_R - print *, 'Input velocities :', vel_L(dir_idx(1)), vel_R(dir_idx(1)) + print *, 'Input velocities :', vel_L(idx), vel_R(idx) print *, 'Sound speeds:', c_L, c_R print *, 'Densities:', rho_L, rho_R print *, 'Pressures:', pres_L, pres_R diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 9bce3682d..ca5dcc2d8 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -674,7 +674,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -1333,7 +1333,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1568,7 +1568,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1894,7 +1894,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2260,7 +2260,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From f5df480488d81d35bbf40aee2faff0ce0926562c Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 22:44:52 -0400 Subject: [PATCH 11/58] Prettifying --- src/common/m_variables_conversion.fpp | 62 ++--- src/simulation/m_riemann_solvers.fpp | 346 +++++++++++++------------- 2 files changed, 204 insertions(+), 204 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 879e4ecdd..eb1305db9 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1733,22 +1733,22 @@ contains !$acc routine seq #endif - ! Input parameters - integer, intent(in) :: wave_speeds - integer, intent(in) :: idx, idx_tau - real(wp), intent(in) :: rho_L, rho_R - real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R - real(wp), intent(in) :: pres_L, pres_R, c_L, c_R - real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R - real(wp), intent(in) :: rho_avg, c_avg - real(wp), intent(in) :: c_fast_L, c_fast_R - real(wp), intent(in) :: G_L, G_R - - ! Local variables - real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R - - ! Output parameters - real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P + ! Input parameters + integer, intent(in) :: wave_speeds + integer, intent(in) :: idx, idx_tau + real(wp), intent(in) :: rho_L, rho_R + real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R + real(wp), intent(in) :: pres_L, pres_R, c_L, c_R + real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R + real(wp), intent(in) :: rho_avg, c_avg + real(wp), intent(in) :: c_fast_L, c_fast_R + real(wp), intent(in) :: G_L, G_R + + ! Local variables + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + + ! Output parameters + real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P if (wave_speeds == 1) then if (mhd) then @@ -1756,34 +1756,34 @@ contains s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) elseif (hypoelasticity .or. elasticity) then s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R)) + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L)) + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) else if (hyperelasticity) then s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) else s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) end if s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* (vel_L(idx) - vel_R(idx))) + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) pres_SR = pres_SL Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) + (pres_SL/pres_L - 1._wp)*pres_L/ & + ((pres_L + pi_inf_L/(1._wp + gamma_L))))) Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) s_L = vel_L(idx) - c_L*Ms_L s_R = vel_R(idx) + c_R*Ms_R s_S = 5e-1_wp*((vel_L(idx) + vel_R(idx)) + (pres_L - pres_R)/(rho_avg*c_avg)) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index ca5dcc2d8..625268c76 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -672,9 +672,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -722,19 +722,19 @@ contains do i = 1, 3 flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + - B%R(i)*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - B%L(i)*B%L(norm_dir) & + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & + + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & /(s_M - s_P) end do ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) elseif (relativity) then @@ -743,20 +743,20 @@ contains ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & + - b4%R(i)/Ga%R*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(i)*vel_L(norm_dir) & - b4%L(i)/Ga%L*B%L(norm_dir) & + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & + + s_M*s_P*(cm%L(i) - cm%R(i))) & /(s_M - s_P) end do ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) end if elseif (bubbles_euler) then @@ -803,11 +803,11 @@ contains flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) else !$acc loop seq do i = 1, num_vels @@ -923,9 +923,9 @@ contains !$acc loop seq do i = 0, 2 flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & - s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) end do end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -1250,12 +1250,12 @@ contains ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do if (hypoelasticity) then !$acc loop seq do i = 1, strxe - strxb + 1 @@ -1331,9 +1331,9 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1566,9 +1566,9 @@ contains vel_avg_rms, 0._wp, c_avg) call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1892,9 +1892,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2178,12 +2178,12 @@ contains ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do if (hypoelasticity) then !$acc loop seq do i = 1, strxe - strxb + 1 @@ -2258,9 +2258,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2462,77 +2462,77 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux ! end contains ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -2703,9 +2703,9 @@ contains ! (5) Compute left/right state vectors and fluxes call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & - U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & - U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star @@ -2721,7 +2721,7 @@ contains U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - + ! (7) Compute the rotational (Alfvén) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) @@ -2775,63 +2775,63 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho - U(2) = rho*vel(1) - U(3) = rho*vel(2) - U(4) = rho*vel(3) - U(5) = B(2) - U(6) = B(3) - U(7) = E - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3) - F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star - U_star(2) = rho_star*s_M - U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3) - U_star(5) = B(2) - U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables ! end contains end subroutine s_hlld_riemann_solver From 82f48468b5965efb1d866ff175c386e877b06a84 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 00:51:23 -0400 Subject: [PATCH 12/58] cleand up redundant loops in s_populate_riemann_states_variables_buffers --- src/simulation/m_riemann_solvers.fpp | 367 ++++++--------------------- 1 file changed, 75 insertions(+), 292 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 625268c76..f3f3f9cf9 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3000,15 +3000,31 @@ contains integer :: i, j, k, l !< Generic loop iterator + pointer :: qL_prim_rs_vf, dqL_prim_d_vf + pointer :: qR_prim_rs_vf, dqR_prim_d_vf + integer :: end_val, bc_beg, bc_end + if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf; qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf; dqR_prim_d_vf => dqR_prim_dx_vf elseif (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + qL_prim_rs_vf => qL_prim_rsy_vf; qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf; dqR_prim_d_vf => dqR_prim_dy_vf + end_val = n else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + qL_prim_rs_vf => qL_prim_rsz_vf; qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf; dqR_prim_d_vf => dqR_prim_dz_vf + end_val = p end if !$acc update device(is1, is2, is3) @@ -3027,317 +3043,84 @@ contains !$acc update device(isx, isy, isz) ! for stuff in the same module !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - ! Population of Buffers in x-direction - if (norm_dir == 1) then - - if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(-1, k, l, i) = & - qR_prim_rsx_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dx_vf(i)%sf(-1, k, l) = & - dqR_prim_dx_vf(i)%sf(0, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dy_vf(i)%sf(-1, k, l) = & - dqR_prim_dy_vf(i)%sf(0, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dz_vf(i)%sf(-1, k, l) = & - dqR_prim_dz_vf(i)%sf(0, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(m + 1, k, l, i) = & - qL_prim_rsx_vf(m, k, l, i) - end do + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) end do end do - - if (viscous) then - + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dx_vf(i)%sf(m, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dy_vf(i)%sf(m, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dz_vf(i)%sf(m, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - ! END: Population of Buffers in x-direction - - ! Population of Buffers in y-direction - elseif (norm_dir == 2) then - - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsy_vf(-1, k, l, i) = & - qR_prim_rsy_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, -1, l) = & - dqR_prim_dx_vf(i)%sf(j, 0, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, -1, l) = & - dqR_prim_dy_vf(i)%sf(j, 0, l) + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, -1, l) = & - dqR_prim_dz_vf(i)%sf(j, 0, l) - end do - end do - end do - end if - - end if - end if - - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsy_vf(n + 1, k, l, i) = & - qL_prim_rsy_vf(n, k, l, i) - end do + end if + + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dx_vf(i)%sf(j, n, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dy_vf(i)%sf(j, n, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dz_vf(i)%sf(j, n, l) - end do - end do - end do - end if - - end if - - end if - ! END: Population of Buffers in y-direction - - ! Population of Buffers in z-direction - else - - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsz_vf(-1, k, l, i) = & - qR_prim_rsz_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = & - dqR_prim_dx_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe + do i = momxb, momxe + do l = isz%beg, isz%end do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = & - dqR_prim_dy_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = & - dqR_prim_dz_vf(i)%sf(j, k, 0) - end do - end do - end do - end if - - end if - - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsz_vf(p + 1, k, l, i) = & - qL_prim_rsz_vf(p, k, l, i) + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if end do end do end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dx_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dy_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dz_vf(i)%sf(j, k, p) - end do - end do - end do - end if - end if - end if - ! END: Population of Buffers in z-direction end subroutine s_populate_riemann_states_variables_buffers From 5dd2eed97d4c62c499d96c1827ac2cf867b45b49 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 18:50:37 -0400 Subject: [PATCH 13/58] corrected pointer implementation in s_populate_riemann_states_variables_buffers --- src/simulation/m_riemann_solvers.fpp | 34 +++++++++++++++++----------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index f3f3f9cf9..72409866b 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2986,45 +2986,53 @@ contains qR_prim_vf, & norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:,:,:,:), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & dqL_prim_dy_vf, dqR_prim_dy_vf, & dqL_prim_dz_vf, dqR_prim_dz_vf, & qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l !< Generic loop iterator - pointer :: qL_prim_rs_vf, dqL_prim_d_vf - pointer :: qR_prim_rs_vf, dqR_prim_d_vf - integer :: end_val, bc_beg, bc_end - if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) bc_beg = bc_x%beg; bc_end = bc_x%end end_val = m - qL_prim_rs_vf => qL_prim_rsx_vf; qR_prim_rs_vf => qR_prim_rsx_vf - dqL_prim_d_vf => dqL_prim_dx_vf; dqR_prim_d_vf => dqR_prim_dx_vf - elseif (norm_dir == 2) then + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) bc_beg = bc_y%beg; bc_end = bc_y%end - qL_prim_rs_vf => qL_prim_rsy_vf; qR_prim_rs_vf => qR_prim_rsy_vf - dqL_prim_d_vf => dqL_prim_dy_vf; dqR_prim_d_vf => dqR_prim_dy_vf end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) bc_beg = bc_z%beg; bc_end = bc_z%end - qL_prim_rs_vf => qL_prim_rsz_vf; qR_prim_rs_vf => qR_prim_rsz_vf - dqL_prim_d_vf => dqL_prim_dz_vf; dqR_prim_d_vf => dqR_prim_dz_vf end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf end if !$acc update device(is1, is2, is3) From 035b34554a4ea34d1609e53b50182a365b56668d Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 19:41:46 -0400 Subject: [PATCH 14/58] refactored s_initialize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 84 ++++++---------------------- 1 file changed, 16 insertions(+), 68 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 72409866b..1917c1fb7 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3163,97 +3163,45 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l ! Generic loop iterators - ! Reshaping Inputted Data in x-direction - if (norm_dir == 1) then - - if (viscous .or. (surface_tension)) then - + if (viscous .or. (surface_tension)) then !$acc parallel loop collapse(4) gang vector default(present) do i = momxb, E_idx do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in y-direction - elseif (norm_dir == 2) then - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in z-direction - else - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = 0._wp + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if end do end do end do end do end if - if (qbmm) then + if (qbmm) then !$acc parallel loop collapse(4) gang vector default(present) do i = 1, 4 do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end + 1 - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if end do end do end do end do end if - end if end subroutine s_initialize_riemann_solver From 11e05c011274158e50dc7b76efa087ec0ad2184e Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:06:29 -0400 Subject: [PATCH 15/58] refactored s_finalize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 143 +++++++-------------------- 1 file changed, 38 insertions(+), 105 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 1917c1fb7..7bc2b6c27 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3598,144 +3598,77 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - end do - end do - end do - end do - - if (cyl_coord) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(advxb)%sf(k, j, l) = & flux_src_rsy_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - end do + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - end if - ! Reshaping Outputted Data in z-direction + ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - end do - end do - end do - end do - if (grid_geometry == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) end do end do end do - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - end do - end do - end do - end do - - end if elseif (norm_dir == 1) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end + + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end do + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) end do end do end do - end if + end do end if end subroutine s_finalize_riemann_solver From e428b07a42c8f969cd6a4d5031e54be1271a557e Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:19:55 -0400 Subject: [PATCH 16/58] finished formatting --- src/simulation/m_riemann_solvers.fpp | 868 +++++++++++++-------------- 1 file changed, 434 insertions(+), 434 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 7bc2b6c27..bfbb17f69 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2987,14 +2987,14 @@ contains norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - real(wp), dimension(:,:,:,:), pointer :: qL_prim_rs_vf, qR_prim_rs_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf type(scalar_field), & dimension(:), & pointer :: dqL_prim_d_vf, dqR_prim_d_vf @@ -3062,35 +3062,35 @@ contains end do end do if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) - if (n > 0) then - dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) - end if - end if - else if (norm_dir == 2) then - dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) - dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) if (p > 0) then - dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) end if - else - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) end if - end do + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do + end do end if end if - + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end !$acc parallel loop collapse(3) gang vector default(present) do i = 1, sys_size @@ -3166,47 +3166,47 @@ contains ! Reshaping Inputted Data in x-direction if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = 0._wp - else if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if - end do + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if end do end do end do - end if + end do + end if if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - if (norm_dir == 1) then - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - else if (norm_dir == 2) then - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - else if (norm_dir == 3) then - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end if - end do + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if end do end do end do - end if + end do + end if end if - end subroutine s_initialize_riemann_solver + end subroutine s_initialize_riemann_solver - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives !! and cylindrical geometric factors, then updates `flux_src_vf`. !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). @@ -3223,153 +3223,153 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if + if (num_dims > 2) then + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp + end if + end do + + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff end if - end do - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select - - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff - if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff - end if + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + if (num_dims > 1) then + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + end if if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + end do + end if - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if + end do end do end do - end do - !$acc end parallel loop + !$acc end parallel loop - end subroutine s_compute_cylindrical_viscous_source_flux + end subroutine s_compute_cylindrical_viscous_source_flux - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. !! Calculates averaged velocity gradients, gets Re and interface velocities, !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). @@ -3385,195 +3385,195 @@ contains !! @param[in] ix X-direction loop bounds (int_bounds_info). !! @param[in] iy Y-direction loop bounds (int_bounds_info). !! @param[in] iz Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - end do - - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) - end do + subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + + divergence_v = 0.0_wp do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) end do - end if - if (shear_stress) then - current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + if (shear_stress) then + current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do - end if + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - if (bulk_stress) then - current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + if (bulk_stress) then + current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do - end if + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do + end if + end do end do end do - end do - !$acc end parallel loop + !$acc end parallel loop - end subroutine s_compute_cartesian_viscous_source_flux + end subroutine s_compute_cartesian_viscous_source_flux - !> @brief Calculates shear stress tensor components. + !> @brief Calculates shear stress tensor components. !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). !! @param[in] Re_shear Shear Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. - tau_shear_out = 0.0_wp + tau_shear_out = 0.0_wp - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear - end if + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do end do - end do - end subroutine s_calculate_shear_stress_tensor + end subroutine s_calculate_shear_stress_tensor - !> @brief Calculates bulk stress tensor components (diagonal only). + !> @brief Calculates bulk stress tensor components (diagonal only). !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. !! @param[in] Re_bulk Bulk Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp + tau_bulk_out = 0.0_wp - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do - end subroutine s_calculate_bulk_stress_tensor + end subroutine s_calculate_bulk_stress_tensor - !> Deallocation and/or disassociation procedures that are + !> Deallocation and/or disassociation procedures that are !! needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes @@ -3582,42 +3582,42 @@ contains !! @param ix Index bounds in first coordinate direction !! @param iy Index bounds in second coordinate direction !! @param iz Index bounds in third coordinate direction - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if + end do end do end do end do - end do - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(4) gang vector default(present) do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end @@ -3631,88 +3631,88 @@ contains flux_gsrc_rsz_vf(j, k, l, i) end if end do - end do - end do - end do - - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) end do end do end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe + + elseif (norm_dir == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do - end do - end if - end subroutine s_finalize_riemann_solver + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) + end do + end do + end do + end do + end if - !> Module deallocation and/or disassociation procedures - subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solver - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if + !> Module deallocation and/or disassociation procedures + subroutine s_finalize_riemann_solvers_module - if (n == 0) return + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if + if (n == 0) return - if (p == 0) return + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if + if (p == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if - end subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solvers_module -end module m_riemann_solvers + end module m_riemann_solvers From 405016310643ffbb712b24f1f42dcec26cd56291 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:58:00 -0400 Subject: [PATCH 17/58] pushing to the test suite --- src/simulation/m_riemann_solvers.fpp | 845 ++++++++++++++------------- 1 file changed, 423 insertions(+), 422 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index bfbb17f69..25daa005e 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3202,11 +3202,10 @@ contains end do end do end if - end if - end subroutine s_initialize_riemann_solver + end subroutine s_initialize_riemann_solver - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives !! and cylindrical geometric factors, then updates `flux_src_vf`. !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). @@ -3223,357 +3222,357 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if - if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp - end if - end do - - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp end if + end do - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp - - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select - - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + if (num_dims > 2) then + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + end if - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cylindrical_viscous_source_flux - - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - !! @param[in] ix X-direction loop bounds (int_bounds_info). - !! @param[in] iy Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s end if if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s end if - end do + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) end do + end if - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) - end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) - end do - end if + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b - if (shear_stress) then - current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cylindrical_viscous_source_flux + + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !! Calculates averaged velocity gradients, gets Re and interface velocities, + !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !! @param[in] ix X-direction loop bounds (int_bounds_info). + !! @param[in] iy Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Z-direction loop bounds (int_bounds_info). + subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) end if - - if (bulk_stress) then - current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) end if + end do + divergence_v = 0.0_wp + do i_dim = 1, num_dims + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) end do - end do - end do - !$acc end parallel loop - end subroutine s_compute_cartesian_viscous_source_flux + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if - !> @brief Calculates shear stress tensor components. - !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear - !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). - !! @param[in] Re_shear Shear Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq + if (shear_stress) then + current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - implicit none + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. + if (bulk_stress) then + current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - tau_shear_out = 0.0_wp + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do end if + end do end do + end do + !$acc end parallel loop + + end subroutine s_compute_cartesian_viscous_source_flux + + !> @brief Calculates shear stress tensor components. + !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear + !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). + !! @param[in] Re_shear Shear Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. + + tau_shear_out = 0.0_wp + + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do + end do - end subroutine s_calculate_shear_stress_tensor + end subroutine s_calculate_shear_stress_tensor - !> @brief Calculates bulk stress tensor components (diagonal only). - !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. - !! @param[in] Re_bulk Bulk Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq + !> @brief Calculates bulk stress tensor components (diagonal only). + !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. + !! @param[in] Re_bulk Bulk Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp + tau_bulk_out = 0.0_wp - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do - end subroutine s_calculate_bulk_stress_tensor + end subroutine s_calculate_bulk_stress_tensor - !> Deallocation and/or disassociation procedures that are + !> Deallocation and/or disassociation procedures that are !! needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes @@ -3582,137 +3581,139 @@ contains !! @param ix Index bounds in first coordinate direction !! @param iy Index bounds in second coordinate direction !! @param iz Index bounds in third coordinate direction - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if - end do + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - if (grid_geometry == 3) then - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end if - end do + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(4) gang vector default(present) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do end do end do + end do - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do + elseif (norm_dir == 1) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) end do end do end do + end do + end if - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end do - end do - end do - end do + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) end if + end do + end do + end do + end do + end if - end subroutine s_finalize_riemann_solver + end subroutine s_finalize_riemann_solver - !> Module deallocation and/or disassociation procedures - subroutine s_finalize_riemann_solvers_module + !> Module deallocation and/or disassociation procedures + subroutine s_finalize_riemann_solvers_module - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if - if (n == 0) return + if (n == 0) return - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if - if (p == 0) return + if (p == 0) return - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if - end subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solvers_module - end module m_riemann_solvers +end module m_riemann_solvers From ca69b3c3564396957bc6613b9fa4d8b9c83a427e Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Wed, 4 Jun 2025 23:36:19 -0400 Subject: [PATCH 18/58] implemented s_compute_wave_speed on all solvers --- src/common/m_variables_conversion.fpp | 107 ++++++++++++ src/simulation/m_riemann_solvers.fpp | 239 +++----------------------- 2 files changed, 129 insertions(+), 217 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 288c2fb0f..1091746de 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1719,4 +1719,111 @@ contains end subroutine s_compute_fast_magnetosonic_speed #endif +#ifndef MFC_PRE_PROCESS + subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, idx, idx_tau) + + ! Computes the wave speeds for the Riemann solver +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_wave_speed +#else + !$acc routine seq +#endif + + ! Input parameters + integer, intent(in) :: wave_speeds + integer, intent(in) :: idx, idx_tau + real(wp), intent(in) :: rho_L, rho_R + real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R + real(wp), intent(in) :: pres_L, pres_R, c_L, c_R + real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R + real(wp), intent(in) :: rho_avg, c_avg + real(wp), intent(in) :: c_fast_L, c_fast_R + real(wp), intent(in) :: G_L, G_R + + ! Local variables + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + + ! Output parameters + real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P + + if (wave_speeds == 1) then + if (elasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) + s_S = (pres_R - tau_e_R(idx_tau) - pres_L + & + tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & + rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & + rho_R*(s_R - vel_R(idx))) + else + else if (mhd) then + s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) + s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) + else if (hypoelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) + else if (hyperelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + else + s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) + s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) + end if + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + end if + else if (wave_speeds == 2) then + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) + pres_SR = pres_SL + Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & + (pres_SL/pres_L - 1._wp)*pres_L/ & + ((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) + s_L = vel_L(idx) - c_L*Ms_L + s_R = vel_R(idx) + c_R*Ms_R + s_S = 5e-1_wp*((vel_L(idx) + vel_R(idx)) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! ! follows Einfeldt et al. + ! s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L) + s_P = max(0._wp, s_R) + +#ifdef DEBUG + ! Check for potential issues in wave speed calculation + if (s_R <= s_L) then + print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' + print *, 'Left wave speed >= Right wave speed:', s_L, s_R + print *, 'Input velocities :', vel_L(idx), vel_R(idx) + print *, 'Sound speeds:', c_L, c_R + print *, 'Densities:', rho_L, rho_R + print *, 'Pressures:', pres_L, pres_R + print *, 'Wave speeds method:', wave_speeds + if (elasticity .or. hypoelasticity .or. hyperelasticity) then + print *, 'Shear moduli:', G_L, G_R + end if + call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') + end if +#endif + + end subroutine s_compute_wave_speed +#endif + end module m_variables_conversion diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 52a464052..2f2cae236 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -330,7 +330,7 @@ contains real(wp) :: alpha_L_sum, alpha_R_sum real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag + type(riemann_states) :: c_fast, pres_mag, vel type(riemann_states_vec3) :: B type(riemann_states) :: Ga ! Gamma (Lorentz factor) @@ -687,62 +687,10 @@ contains end do end if - if (wave_speeds == 1) then - if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) - s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) - elseif (hypoelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L)) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - end if - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -1264,6 +1212,7 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi + type(riemann_states) :: c_fast, vel ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -1497,51 +1446,10 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - if (wave_speeds == 1) then - if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(idx1)*(s_L - vel_L(idx1)) - & - rho_R*vel_R(idx1)*(s_R - vel_R(idx1)))/(rho_L*(s_L - vel_L(idx1)) - & - rho_R*(s_R - vel_R(idx1))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - - end if - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1807,41 +1715,10 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - if (wave_speeds == 1) then - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2236,41 +2113,10 @@ contains @:compute_low_Mach_correction() end if - if (wave_speeds == 1) then - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2705,51 +2551,10 @@ contains @:compute_low_Mach_correction() end if - if (wave_speeds == 1) then - if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(dir_idx_tau(1)))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + & - tau_e_L(dir_idx_tau(1)) + rho_L*vel_L(idx1)*(s_L - vel_L(idx1)) - & - rho_R*vel_R(idx1)*(s_R - vel_R(idx1)))/(rho_L*(s_L - vel_L(idx1)) - & - rho_R*(s_R - vel_R(idx1))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - - end if - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(idx1) - & - vel_R(idx1))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(idx1) - c_L*Ms_L - s_R = vel_R(idx1) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(idx1) + vel_R(idx1)) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From fdbdcae37a628cf380172dd5a6d77b794575678f Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 00:00:11 -0400 Subject: [PATCH 19/58] s_compute_wave_speed passed Hypoelasticity tests --- src/common/m_variables_conversion.fpp | 55 +++++++++++++++------------ 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 1091746de..f1dbe6ee8 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -44,6 +44,7 @@ module m_variables_conversion #ifndef MFC_PRE_PROCESS s_compute_speed_of_sound, & s_compute_fast_magnetosonic_speed, & + s_compute_wave_speed, & #endif s_finalize_variables_conversion_module @@ -1761,31 +1762,38 @@ contains tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & rho_R*(s_R - vel_R(idx))) + else if (mhd) then + s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) + s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + else if (hypoelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + else if (hyperelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) else - else if (mhd) then - s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) - s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) - else if (hypoelasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) - else - s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) - s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) - end if + s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) + s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) end if else if (wave_speeds == 2) then pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) @@ -1822,7 +1830,6 @@ contains call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') end if #endif - end subroutine s_compute_wave_speed #endif From c60ff19fbcb0e656dc391980e5e8f369b03dd630 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 00:29:24 -0400 Subject: [PATCH 20/58] non-solver subroutines refactor --- src/simulation/m_riemann_solvers.fpp | 639 +++++++-------------------- 1 file changed, 156 insertions(+), 483 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 2f2cae236..e998e0af8 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -330,7 +330,7 @@ contains real(wp) :: alpha_L_sum, alpha_R_sum real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag, vel + type(riemann_states) :: c_fast, pres_mag type(riemann_states_vec3) :: B type(riemann_states) :: Ga ! Gamma (Lorentz factor) @@ -2551,10 +2551,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -3264,14 +3264,20 @@ contains qR_prim_vf, & norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -3281,12 +3287,30 @@ contains if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - elseif (norm_dir == 2) then + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf end if !$acc update device(is1, is2, is3) @@ -3305,317 +3329,84 @@ contains !$acc update device(isx, isy, isz) ! for stuff in the same module !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - ! Population of Buffers in x-direction - if (norm_dir == 1) then - - if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(-1, k, l, i) = & - qR_prim_rsx_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dx_vf(i)%sf(-1, k, l) = & - dqR_prim_dx_vf(i)%sf(0, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dy_vf(i)%sf(-1, k, l) = & - dqR_prim_dy_vf(i)%sf(0, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dz_vf(i)%sf(-1, k, l) = & - dqR_prim_dz_vf(i)%sf(0, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(m + 1, k, l, i) = & - qL_prim_rsx_vf(m, k, l, i) - end do + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dx_vf(i)%sf(m, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dy_vf(i)%sf(m, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dz_vf(i)%sf(m, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - ! END: Population of Buffers in x-direction - - ! Population of Buffers in y-direction - elseif (norm_dir == 2) then - - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsy_vf(-1, k, l, i) = & - qR_prim_rsy_vf(0, k, l, i) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, -1, l) = & - dqR_prim_dx_vf(i)%sf(j, 0, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, -1, l) = & - dqR_prim_dy_vf(i)%sf(j, 0, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, -1, l) = & - dqR_prim_dz_vf(i)%sf(j, 0, l) - end do - end do - end do - end if - - end if - end if + end if - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsy_vf(n + 1, k, l, i) = & - qL_prim_rsy_vf(n, k, l, i) - end do + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dx_vf(i)%sf(j, n, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dy_vf(i)%sf(j, n, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dz_vf(i)%sf(j, n, l) - end do - end do - end do - end if - - end if - - end if - ! END: Population of Buffers in y-direction - - ! Population of Buffers in z-direction - else - - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsz_vf(-1, k, l, i) = & - qR_prim_rsz_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = & - dqR_prim_dx_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = & - dqR_prim_dy_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe + do i = momxb, momxe + do l = isz%beg, isz%end do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = & - dqR_prim_dz_vf(i)%sf(j, k, 0) - end do - end do - end do - end if - - end if - - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsz_vf(p + 1, k, l, i) = & - qL_prim_rsz_vf(p, k, l, i) + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if end do end do end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dx_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dy_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dz_vf(i)%sf(j, k, p) - end do - end do - end do - end if - end if - end if - ! END: Population of Buffers in z-direction end subroutine s_populate_riemann_states_variables_buffers @@ -3650,97 +3441,44 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l ! Generic loop iterators - ! Reshaping Inputted Data in x-direction - if (norm_dir == 1) then - - if (viscous .or. (surface_tension)) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in y-direction - elseif (norm_dir == 2) then - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end do j = is1%beg, is1%end - do k = is2%beg, is2%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then flux_src_vf(i)%sf(k, j, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in z-direction - else - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end + else if (norm_dir == 3) then flux_src_vf(i)%sf(l, k, j) = 0._wp - end do + end if end do end do end do - end if + end do + end if - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end do + end if end do end do end do - end if - + end do end if end subroutine s_initialize_riemann_solver @@ -4137,144 +3875,79 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - end do - end do - end do - end do - - if (cyl_coord) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(advxb)%sf(k, j, l) = & flux_src_rsy_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - end do + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - end if ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - end do - end do - end do - end do - if (grid_geometry == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end flux_src_vf(advxb)%sf(l, k, j) = & flux_src_rsz_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - end do + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do end do end do + end do - end if elseif (norm_dir == 1) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do + end if - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end do k = is2%beg, is2%end - do j = is1%beg, is1%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then flux_src_vf(i)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, i) - end do + end if end do end do end do - end if + end do end if end subroutine s_finalize_riemann_solver From 59871223968ed097a9aedb7097ea5789261c3000 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 01:01:42 -0400 Subject: [PATCH 21/58] s_hlld_riemann_solver passed Hypoelasticity tests --- src/simulation/m_riemann_solvers.fpp | 158 +++++++++++++-------------- 1 file changed, 74 insertions(+), 84 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e998e0af8..8b203c7ab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2850,7 +2850,6 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2970,74 +2969,15 @@ contains E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - ! (5) Compute the left/right conserved state vectors - U_L(1) = rho%L - U_L(2) = rho%L*vel%L(1) - U_L(3) = rho%L*vel%L(2) - U_L(4) = rho%L*vel%L(3) - U_L(5) = B%L(2) - U_L(6) = B%L(3) - U_L(7) = E%L - - U_R(1) = rho%R - U_R(2) = rho%R*vel%R(1) - U_R(3) = rho%R*vel%R(2) - U_R(4) = rho%R*vel%R(3) - U_R(5) = B%R(2) - U_R(6) = B%R(3) - U_R(7) = E%R - - ! (6) Compute the left/right star state vectors - U_starL(1) = rhoL_star - U_starL(2) = rhoL_star*s_M - U_starL(3) = rhoL_star*vel%L(2) - U_starL(4) = rhoL_star*vel%L(3) - U_starL(5) = B%L(2) - U_starL(6) = B%L(3) - U_starL(7) = E_starL - - U_starR(1) = rhoR_star - U_starR(2) = rhoR_star*s_M - U_starR(3) = rhoR_star*vel%R(2) - U_starR(4) = rhoR_star*vel%R(3) - U_starR(5) = B%R(2) - U_starR(6) = B%R(3) - U_starR(7) = E_starR - - ! (7) Compute the left/right fluxes - F_L(1) = rho%L*vel%L(1) - F_L(2) = rho%L*vel%L(1)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3) = rho%L*vel%L(1)*vel%L(2) - B%L(1)*B%L(2) - F_L(4) = rho%L*vel%L(1)*vel%L(3) - B%L(1)*B%L(3) - F_L(5) = vel%L(1)*B%L(2) - vel%L(2)*B%L(1) - F_L(6) = vel%L(1)*B%L(3) - vel%L(3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) - - F_R(1) = rho%R*vel%R(1) - F_R(2) = rho%R*vel%R(1)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3) = rho%R*vel%R(1)*vel%R(2) - B%R(1)*B%R(2) - F_R(4) = rho%R*vel%R(1)*vel%R(3) - B%R(1)*B%R(3) - F_R(5) = vel%R(1)*B%R(2) - vel%R(2)*B%R(1) - F_R(6) = vel%R(1)*B%R(3) - vel%R(3)*B%R(1) - F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - - ! (8) Compute the left/right star fluxes (note array operations) - F_starL = F_L + s_L*(U_starL - U_L) - F_starR = F_R + s_R*(U_starR - U_R) - - ! (9) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! (5) Compute left/right state vectors and fluxes + call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) - ! (10) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - sqrt_rhoL_star = sqrt(rhoL_star) - sqrt_rhoR_star = sqrt(rhoR_star) + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star sign_Bx = sign(1._wp, B%L(1)) - vL_star = vel%L(2) - wL_star = vel%L(3) - vR_star = vel%R(2) - wR_star = vel%R(3) v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds @@ -3047,23 +2987,14 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL(1) = rhoL_star - U_doubleL(2) = rhoL_star*s_M - U_doubleL(3) = rhoL_star*v_double - U_doubleL(4) = rhoL_star*w_double - U_doubleL(5) = By_double - U_doubleL(6) = Bz_double - U_doubleL(7) = E_double - - U_doubleR(1) = rhoR_star - U_doubleR(2) = rhoR_star*s_M - U_doubleR(3) = rhoR_star*v_double - U_doubleR(4) = rhoR_star*w_double - U_doubleR(5) = By_double - U_doubleR(6) = Bz_double - U_doubleR(7) = E_double - - ! (11) Choose HLLD flux based on wave-speed regions + U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -3078,7 +3009,7 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array + ! (9) Reorder and write temporary variables to the flux array ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum @@ -3111,6 +3042,65 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) + + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables + ! end contains end subroutine s_hlld_riemann_solver !> The computation of parameters, the allocation of memory, From 062d51d0df90a495338d2df57f633a020a538ac0 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 01:44:00 -0400 Subject: [PATCH 22/58] s_hllc_riemann_solver passed Hypoelasticity tests --- src/simulation/m_riemann_solvers.fpp | 310 ++++++++++----------------- 1 file changed, 115 insertions(+), 195 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 8b203c7ab..106b7f69a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1290,15 +1290,6 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) @@ -1306,6 +1297,7 @@ contains !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -1330,91 +1322,75 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - + Re_R(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0._wp - + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) then G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids G_L = G_L + alpha_L(i)*Gs(i) G_R = G_R + alpha_R(i)*Gs(i) end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -1674,20 +1650,17 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - end do - rho_R = 0._wp gamma_R = 0._wp pi_inf_R = 0._wp qv_R = 0._wp + !$acc loop seq do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) rho_R = rho_R + alpha_rho_R(i) gamma_R = gamma_R + alpha_R(i)*gammas(i) pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) @@ -1695,7 +1668,6 @@ contains end do E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L @@ -1803,7 +1775,6 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) if (cyl_coord) then ! Substituting the advective flux into the inviscid geometrical source flux @@ -1885,6 +1856,10 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then @@ -1894,30 +1869,6 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else - rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - end if - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) @@ -1926,12 +1877,20 @@ contains else if (num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) end do else + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) @@ -1943,38 +1902,25 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L @@ -2342,22 +2288,13 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2379,31 +2316,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -2460,67 +2385,63 @@ contains H_R = (E_R + pres_R)/rho_R else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R end if - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) then + G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids G_L = G_L + alpha_L(i)*Gs(i) G_R = G_R + alpha_R(i)*Gs(i) end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -2804,7 +2725,6 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) - end subroutine s_hllc_riemann_solver !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: From 3fff3b110128f156c4c0925bcf7c6dd2a0bfe8d6 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 02:06:15 -0400 Subject: [PATCH 23/58] s_hll_riemann_solver passed Hypoelasticity tests --- src/simulation/m_riemann_solvers.fpp | 97 ++++++++++++---------------- 1 file changed, 41 insertions(+), 56 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 106b7f69a..a76b12236 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -474,31 +474,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -552,44 +540,41 @@ contains E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R - elseif (mhd .and. relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L - b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R - b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R - b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - - cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) - cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) - cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) - cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) - cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) - cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (mhd .and. .not. relativity) then - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + elseif (mhd) then + if (relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + !acc loop seq + do i = 1, 3 + b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L + b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R + end do + + B2%L = sum(B%L**2._wp) + B2%R = sum(B%R**2._wp) + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + !acc loop seq + do i = 1, 3 + cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) + cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) + end do + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (.not. relativity) then + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + end if else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R From cce093a86ed3f4504674561dd13040a89a936a89 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Sun, 1 Jun 2025 21:29:04 -0400 Subject: [PATCH 24/58] implemented s_compute_wave_speed on all solvers --- src/simulation/m_riemann_solvers.fpp | 1309 +++++++++++++++++--------- 1 file changed, 870 insertions(+), 439 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index a76b12236..2bda4153a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -202,17 +202,17 @@ contains !! For more information please refer to: !! 1) s_compute_cartesian_viscous_source_flux !! 2) s_compute_cylindrical_viscous_source_flux - pure subroutine s_compute_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) + subroutine s_compute_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) type(scalar_field), & dimension(num_vels), & @@ -474,19 +474,31 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if + + if (Re_size(i) > 0) Re_L(i) = 0._wp + !$acc loop seq do q = 1, Re_size(i) Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -540,41 +552,44 @@ contains E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R - elseif (mhd) then - if (relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - !acc loop seq - do i = 1, 3 - b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L - b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R - end do - - B2%L = sum(B%L**2._wp) - B2%R = sum(B%R**2._wp) - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - !acc loop seq - do i = 1, 3 - cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) - cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) - end do - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (.not. relativity) then - pres_mag%L = 0.5_wp*sum(B%L**2._wp) - pres_mag%R = 0.5_wp*sum(B%R**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - end if + elseif (mhd .and. relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L + b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L + b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L + b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R + b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R + B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp + B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp + + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + + cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) + cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) + cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) + cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) + cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) + cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) + + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (mhd .and. .not. relativity) then + pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) + pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R @@ -672,10 +687,10 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -1197,7 +1212,6 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi - type(riemann_states) :: c_fast, vel ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -1275,6 +1289,15 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + end do + + !$acc loop seq + do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) @@ -1282,7 +1305,6 @@ contains !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -1307,75 +1329,91 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - Re_R(i) = dflt_real + if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp + !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) then + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids G_L = G_L + alpha_L(i)*Gs(i) G_R = G_R + alpha_R(i)*Gs(i) end do - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if end if - end do - else if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do + end do + end if + + ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if H_L = (E_L + pres_L)/rho_L @@ -1407,10 +1445,10 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1635,17 +1673,20 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - !$acc loop seq do i = 1, num_fluids rho_L = rho_L + alpha_rho_L(i) gamma_L = gamma_L + alpha_L(i)*gammas(i) pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) qv_L = qv_L + alpha_rho_L(i)*qvs(i) + end do + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + !$acc loop seq + do i = 1, num_fluids rho_R = rho_R + alpha_rho_R(i) gamma_R = gamma_R + alpha_R(i)*gammas(i) pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) @@ -1653,6 +1694,7 @@ contains end do E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L @@ -1672,10 +1714,10 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1760,6 +1802,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) if (cyl_coord) then ! Substituting the advective flux into the inviscid geometrical source flux @@ -1841,10 +1884,6 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then @@ -1854,10 +1893,6 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) end do else if (num_fluids > 2) then !$acc loop seq @@ -1866,16 +1901,36 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) end do else rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) gamma_L = gammas(1) pi_inf_L = pi_infs(1) qv_L = qvs(1) + end if + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else if (num_fluids > 2) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) @@ -1887,25 +1942,38 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if + + if (Re_size(i) > 0) Re_L(i) = 0._wp + !$acc loop seq do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L @@ -2044,10 +2112,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2273,13 +2341,22 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + end do + + !$acc loop seq + do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do + !$acc loop seq do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2301,19 +2378,31 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if + + if (Re_size(i) > 0) Re_L(i) = 0._wp + !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -2370,63 +2459,67 @@ contains H_R = (E_R + pres_R)/rho_R else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R end if - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + G_L = 0_wp + G_R = 0_wp !$acc loop seq do i = 1, num_fluids G_L = G_L + alpha_L(i)*Gs(i) G_R = G_R + alpha_R(i)*Gs(i) end do - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if end if - end do - else if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do + end do + end if + + ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp + G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if H_L = (E_L + pres_L)/rho_L @@ -2457,10 +2550,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & + c_L, c_R, c_avg, c_fast, G_L, G_R, & + tau_e_L, tau_e_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2710,6 +2803,7 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) + end subroutine s_hllc_riemann_solver !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: @@ -2755,6 +2849,7 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld + ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2874,15 +2969,74 @@ contains E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - ! (5) Compute left/right state vectors and fluxes - call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & - U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) - call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & - U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) + ! (5) Compute the left/right conserved state vectors + U_L(1) = rho%L + U_L(2) = rho%L*vel%L(1) + U_L(3) = rho%L*vel%L(2) + U_L(4) = rho%L*vel%L(3) + U_L(5) = B%L(2) + U_L(6) = B%L(3) + U_L(7) = E%L + + U_R(1) = rho%R + U_R(2) = rho%R*vel%R(1) + U_R(3) = rho%R*vel%R(2) + U_R(4) = rho%R*vel%R(3) + U_R(5) = B%R(2) + U_R(6) = B%R(3) + U_R(7) = E%R + + ! (6) Compute the left/right star state vectors + U_starL(1) = rhoL_star + U_starL(2) = rhoL_star*s_M + U_starL(3) = rhoL_star*vel%L(2) + U_starL(4) = rhoL_star*vel%L(3) + U_starL(5) = B%L(2) + U_starL(6) = B%L(3) + U_starL(7) = E_starL + + U_starR(1) = rhoR_star + U_starR(2) = rhoR_star*s_M + U_starR(3) = rhoR_star*vel%R(2) + U_starR(4) = rhoR_star*vel%R(3) + U_starR(5) = B%R(2) + U_starR(6) = B%R(3) + U_starR(7) = E_starR + + ! (7) Compute the left/right fluxes + F_L(1) = rho%L*vel%L(1) + F_L(2) = rho%L*vel%L(1)*vel%L(1) - B%L(1)*B%L(1) + pTot_L + F_L(3) = rho%L*vel%L(1)*vel%L(2) - B%L(1)*B%L(2) + F_L(4) = rho%L*vel%L(1)*vel%L(3) - B%L(1)*B%L(3) + F_L(5) = vel%L(1)*B%L(2) - vel%L(2)*B%L(1) + F_L(6) = vel%L(1)*B%L(3) - vel%L(3)*B%L(1) + F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + + F_R(1) = rho%R*vel%R(1) + F_R(2) = rho%R*vel%R(1)*vel%R(1) - B%R(1)*B%R(1) + pTot_R + F_R(3) = rho%R*vel%R(1)*vel%R(2) - B%R(1)*B%R(2) + F_R(4) = rho%R*vel%R(1)*vel%R(3) - B%R(1)*B%R(3) + F_R(5) = vel%R(1)*B%R(2) - vel%R(2)*B%R(1) + F_R(6) = vel%R(1)*B%R(3) - vel%R(3)*B%R(1) + F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) + + ! (8) Compute the left/right star fluxes (note array operations) + F_starL = F_L + s_L*(U_starL - U_L) + F_starR = F_R + s_R*(U_starR - U_R) + + ! (9) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] + ! (10) Compute the double–star states [Miyoshi Eqns. (59)-(62)] + sqrt_rhoL_star = sqrt(rhoL_star) + sqrt_rhoR_star = sqrt(rhoR_star) denom_ds = sqrt_rhoL_star + sqrt_rhoR_star sign_Bx = sign(1._wp, B%L(1)) + vL_star = vel%L(2) + wL_star = vel%L(3) + vR_star = vel%R(2) + wR_star = vel%R(3) v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds @@ -2892,14 +3046,23 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - - ! (7) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - - ! (8) Choose HLLD flux based on wave-speed regions + U_doubleL(1) = rhoL_star + U_doubleL(2) = rhoL_star*s_M + U_doubleL(3) = rhoL_star*v_double + U_doubleL(4) = rhoL_star*w_double + U_doubleL(5) = By_double + U_doubleL(6) = Bz_double + U_doubleL(7) = E_double + + U_doubleR(1) = rhoR_star + U_doubleR(2) = rhoR_star*s_M + U_doubleR(3) = rhoR_star*v_double + U_doubleR(4) = rhoR_star*w_double + U_doubleR(5) = By_double + U_doubleR(6) = Bz_double + U_doubleR(7) = E_double + + ! (11) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -2914,7 +3077,7 @@ contains F_hlld = F_R end if - ! (9) Reorder and write temporary variables to the flux array + ! (12) Reorder and write temporary variables to the flux array ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum @@ -2947,71 +3110,12 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) - - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho - U(2) = rho*vel(1) - U(3) = rho*vel(2) - U(4) = rho*vel(3) - U(5) = B(2) - U(6) = B(3) - U(7) = E - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3) - F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star - U_star(2) = rho_star*s_M - U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3) - U_star(5) = B(2) - U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables - ! end contains end subroutine s_hlld_riemann_solver !> The computation of parameters, the allocation of memory, !! the association of pointers and/or the execution of any !! other procedures that are necessary to setup the module. - impure subroutine s_initialize_riemann_solvers_module + subroutine s_initialize_riemann_solvers_module ! Allocating the variables that will be utilized to formulate the ! left, right, and average states of the Riemann problem, as well @@ -3159,20 +3263,14 @@ contains qR_prim_vf, & norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf type(scalar_field), & allocatable, dimension(:), & - target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf - type(scalar_field), & - dimension(:), & - pointer :: dqL_prim_d_vf, dqR_prim_d_vf - - integer :: end_val, bc_beg, bc_end + intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -3182,30 +3280,12 @@ contains if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - bc_beg = bc_x%beg; bc_end = bc_x%end - end_val = m - qL_prim_rs_vf => qL_prim_rsx_vf - qR_prim_rs_vf => qR_prim_rsx_vf - dqL_prim_d_vf => dqL_prim_dx_vf - dqR_prim_d_vf => dqR_prim_dx_vf - else if (norm_dir == 2) then + elseif (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) - bc_beg = bc_y%beg; bc_end = bc_y%end - end_val = n - qL_prim_rs_vf => qL_prim_rsy_vf - qR_prim_rs_vf => qR_prim_rsy_vf - dqL_prim_d_vf => dqL_prim_dy_vf - dqR_prim_d_vf => dqR_prim_dy_vf else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) - bc_beg = bc_z%beg; bc_end = bc_z%end - end_val = p - qL_prim_rs_vf => qL_prim_rsz_vf - qR_prim_rs_vf => qR_prim_rsz_vf - dqL_prim_d_vf => dqL_prim_dz_vf - dqR_prim_d_vf => dqR_prim_dz_vf end if !$acc update device(is1, is2, is3) @@ -3224,84 +3304,317 @@ contains !$acc update device(isx, isy, isz) ! for stuff in the same module !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - ! Population of Buffers in x/y/z-direction - if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) + ! Population of Buffers in x-direction + if (norm_dir == 1) then + + if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rsx_vf(-1, k, l, i) = & + qR_prim_rsx_vf(0, k, l, i) + end do end do end do - end do - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) - if (n > 0) then - dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) - end if - end if - else if (norm_dir == 2) then - dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) - dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) - end if - else - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) - end if + + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqL_prim_dx_vf(i)%sf(-1, k, l) = & + dqR_prim_dx_vf(i)%sf(0, k, l) + end do + end do + end do + + if (n > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqL_prim_dy_vf(i)%sf(-1, k, l) = & + dqR_prim_dy_vf(i)%sf(0, k, l) + end do + end do + end do + + if (p > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqL_prim_dz_vf(i)%sf(-1, k, l) = & + dqR_prim_dz_vf(i)%sf(0, k, l) + end do + end do + end do + end if + + end if + + end if + + end if + + if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rsx_vf(m + 1, k, l, i) = & + qL_prim_rsx_vf(m, k, l, i) end do end do end do + + if (viscous) then + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & + dqL_prim_dx_vf(i)%sf(m, k, l) + end do + end do + end do + + if (n > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & + dqL_prim_dy_vf(i)%sf(m, k, l) + end do + end do + end do + + if (p > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + + dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & + dqL_prim_dz_vf(i)%sf(m, k, l) + end do + end do + end do + end if + + end if + + end if + end if - end if + ! END: Population of Buffers in x-direction - if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) + ! Population of Buffers in y-direction + elseif (norm_dir == 2) then + + if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rsy_vf(-1, k, l, i) = & + qR_prim_rsy_vf(0, k, l, i) + end do end do end do - end do - if (viscous) then + + if (viscous) then + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqL_prim_dx_vf(i)%sf(j, -1, l) = & + dqR_prim_dx_vf(i)%sf(j, 0, l) + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqL_prim_dy_vf(i)%sf(j, -1, l) = & + dqR_prim_dy_vf(i)%sf(j, 0, l) + end do + end do + end do + + if (p > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqL_prim_dz_vf(i)%sf(j, -1, l) = & + dqR_prim_dz_vf(i)%sf(j, 0, l) + end do + end do + end do + end if + + end if + + end if + + if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rsy_vf(n + 1, k, l, i) = & + qL_prim_rsy_vf(n, k, l, i) + end do + end do + end do + + if (viscous) then + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & + dqL_prim_dx_vf(i)%sf(j, n, l) + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & + dqL_prim_dy_vf(i)%sf(j, n, l) + end do + end do + end do + + if (p > 0) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do j = isx%beg, isx%end + dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & + dqL_prim_dz_vf(i)%sf(j, n, l) + end do + end do + end do + end if + + end if + + end if + ! END: Population of Buffers in y-direction + + ! Population of Buffers in z-direction + else + + if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rsz_vf(-1, k, l, i) = & + qR_prim_rsz_vf(0, k, l, i) + end do + end do + end do + + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe do k = isy%beg, isy%end - if (norm_dir == 1) then - dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) - if (n > 0) then - dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) - end if - end if - else if (norm_dir == 2) then - dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) - dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) - end if - else - dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) - dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) - dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) - end if + do j = isx%beg, isx%end + dqL_prim_dx_vf(i)%sf(j, k, -1) = & + dqR_prim_dx_vf(i)%sf(j, k, 0) + end do + end do + end do + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqL_prim_dy_vf(i)%sf(j, k, -1) = & + dqR_prim_dy_vf(i)%sf(j, k, 0) + end do + end do + end do + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqL_prim_dz_vf(i)%sf(j, k, -1) = & + dqR_prim_dz_vf(i)%sf(j, k, 0) + end do + end do + end do + end if + + end if + + if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rsz_vf(p + 1, k, l, i) = & + qL_prim_rsz_vf(p, k, l, i) end do end do end do + + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & + dqL_prim_dx_vf(i)%sf(j, k, p) + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & + dqL_prim_dy_vf(i)%sf(j, k, p) + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & + dqL_prim_dz_vf(i)%sf(j, k, p) + end do + end do + end do + end if + end if + end if + ! END: Population of Buffers in z-direction end subroutine s_populate_riemann_states_variables_buffers @@ -3336,44 +3649,97 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l ! Generic loop iterators + ! Reshaping Inputted Data in x-direction - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (norm_dir == 1) then + if (norm_dir == 1) then + + if (viscous .or. (surface_tension)) then + + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end flux_src_vf(i)%sf(j, k, l) = 0._wp - else if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if + end do end do end do end do - end do - end if + end if - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - if (norm_dir == 1) then + if (qbmm) then + + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - else if (norm_dir == 2) then + end do + end do + end do + end do + end if + + ! Reshaping Inputted Data in y-direction + elseif (norm_dir == 2) then + + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(i)%sf(k, j, l) = 0._wp + end do + end do + end do + end do + end if + + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - else if (norm_dir == 3) then + end do + end do + end do + end do + end if + + ! Reshaping Inputted Data in z-direction + else + + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(i)%sf(l, k, j) = 0._wp + end do + end do + end do + end do + end if + + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end if + end do end do end do end do - end do + end if + end if end subroutine s_initialize_riemann_solver @@ -3395,11 +3761,11 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - pure subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf @@ -3557,17 +3923,17 @@ contains !! @param[in] ix X-direction loop bounds (int_bounds_info). !! @param[in] iy Y-direction loop bounds (int_bounds_info). !! @param[in] iz Z-direction loop bounds (int_bounds_info). - pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) + subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) ! Arguments type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf @@ -3650,7 +4016,7 @@ contains end if if (shear_stress) then - ! current_tau_shear = 0.0_wp + current_tau_shear = 0.0_wp call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) do i_dim = 1, num_dims @@ -3664,7 +4030,7 @@ contains end if if (bulk_stress) then - ! current_tau_bulk = 0.0_wp + current_tau_bulk = 0.0_wp call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) do i_dim = 1, num_dims @@ -3690,7 +4056,7 @@ contains !! @param[in] Re_shear Shear Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - pure subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) !$acc routine seq implicit none @@ -3724,7 +4090,7 @@ contains !! @param[in] Re_bulk Bulk Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - pure subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) !$acc routine seq implicit none @@ -3754,9 +4120,9 @@ contains !! @param ix Index bounds in first coordinate direction !! @param iy Index bounds in second coordinate direction !! @param iz Index bounds in third coordinate direction - pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) type(scalar_field), & dimension(sys_size), & @@ -3770,85 +4136,150 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size + do i = 1, sys_size + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end flux_vf(i)%sf(k, j, l) = & flux_rsy_vf(j, k, l, i) - if (cyl_coord) then + end do + end do + end do + end do + + if (cyl_coord) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end flux_gsrc_vf(i)%sf(k, j, l) = & flux_gsrc_rsy_vf(j, k, l, i) - end if + end do end do end do end do + end if + + !$acc parallel loop collapse(3) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + end do + end do end do + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + end do + end do + end do + end do + + end if ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then !$acc parallel loop collapse(4) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) - do i = 1, sys_size + do i = 1, sys_size + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_vf(i)%sf(l, k, j) = & flux_rsz_vf(j, k, l, i) - if (grid_geometry == 3) then + end do + end do + end do + end do + if (grid_geometry == 3) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, sys_size + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_gsrc_vf(i)%sf(l, k, j) = & flux_gsrc_rsz_vf(j, k, l, i) - end if + end do end do end do end do + end if + + !$acc parallel loop collapse(3) gang vector default(present) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + end do + end do end do + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + end do + end do + end do + end do + + end if elseif (norm_dir == 1) then !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do + end do + end do + end do + + !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do end do end do end do - end if - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then + do j = is1%beg, is1%end flux_src_vf(i)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, i) - end if + end do end do end do end do - end do + end if end if end subroutine s_finalize_riemann_solver !> Module deallocation and/or disassociation procedures - impure subroutine s_finalize_riemann_solvers_module + subroutine s_finalize_riemann_solvers_module if (viscous) then @:DEALLOCATE(Re_avg_rsx_vf) From b74ce959db688a74fbc9ed896b26fe9940a7ffa5 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Sun, 1 Jun 2025 22:29:08 -0400 Subject: [PATCH 25/58] cleaned up s_hlld_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 144 +++++++++++---------------- 1 file changed, 60 insertions(+), 84 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 2bda4153a..532cfcd59 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2849,7 +2849,7 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - + real ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2859,6 +2859,50 @@ contains real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double integer :: i, j, k, l + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho, U(2) = rho*vel(1), U(3) = rho*vel(2), U(4) = rho*vel(3) + U(5) = B(2), U(6) = B(3), U(7) = E + ! Compute the flux vector + F(1) = U(2), F(2) = U(2)*vel(1) - B(1)*B(1) + pTot, F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3), F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1), F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star, U_star(2) = rho_star*s_M, U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3), U_star(5) = B(2), U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -2969,74 +3013,15 @@ contains E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - ! (5) Compute the left/right conserved state vectors - U_L(1) = rho%L - U_L(2) = rho%L*vel%L(1) - U_L(3) = rho%L*vel%L(2) - U_L(4) = rho%L*vel%L(3) - U_L(5) = B%L(2) - U_L(6) = B%L(3) - U_L(7) = E%L - - U_R(1) = rho%R - U_R(2) = rho%R*vel%R(1) - U_R(3) = rho%R*vel%R(2) - U_R(4) = rho%R*vel%R(3) - U_R(5) = B%R(2) - U_R(6) = B%R(3) - U_R(7) = E%R - - ! (6) Compute the left/right star state vectors - U_starL(1) = rhoL_star - U_starL(2) = rhoL_star*s_M - U_starL(3) = rhoL_star*vel%L(2) - U_starL(4) = rhoL_star*vel%L(3) - U_starL(5) = B%L(2) - U_starL(6) = B%L(3) - U_starL(7) = E_starL - - U_starR(1) = rhoR_star - U_starR(2) = rhoR_star*s_M - U_starR(3) = rhoR_star*vel%R(2) - U_starR(4) = rhoR_star*vel%R(3) - U_starR(5) = B%R(2) - U_starR(6) = B%R(3) - U_starR(7) = E_starR - - ! (7) Compute the left/right fluxes - F_L(1) = rho%L*vel%L(1) - F_L(2) = rho%L*vel%L(1)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3) = rho%L*vel%L(1)*vel%L(2) - B%L(1)*B%L(2) - F_L(4) = rho%L*vel%L(1)*vel%L(3) - B%L(1)*B%L(3) - F_L(5) = vel%L(1)*B%L(2) - vel%L(2)*B%L(1) - F_L(6) = vel%L(1)*B%L(3) - vel%L(3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) - - F_R(1) = rho%R*vel%R(1) - F_R(2) = rho%R*vel%R(1)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3) = rho%R*vel%R(1)*vel%R(2) - B%R(1)*B%R(2) - F_R(4) = rho%R*vel%R(1)*vel%R(3) - B%R(1)*B%R(3) - F_R(5) = vel%R(1)*B%R(2) - vel%R(2)*B%R(1) - F_R(6) = vel%R(1)*B%R(3) - vel%R(3)*B%R(1) - F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - - ! (8) Compute the left/right star fluxes (note array operations) - F_starL = F_L + s_L*(U_starL - U_L) - F_starR = F_R + s_R*(U_starR - U_R) - - ! (9) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! (5) Compute left/right state vectors and fluxes + call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) - ! (10) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - sqrt_rhoL_star = sqrt(rhoL_star) - sqrt_rhoR_star = sqrt(rhoR_star) + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star sign_Bx = sign(1._wp, B%L(1)) - vL_star = vel%L(2) - wL_star = vel%L(3) - vR_star = vel%R(2) - wR_star = vel%R(3) v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds @@ -3046,23 +3031,14 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL(1) = rhoL_star - U_doubleL(2) = rhoL_star*s_M - U_doubleL(3) = rhoL_star*v_double - U_doubleL(4) = rhoL_star*w_double - U_doubleL(5) = By_double - U_doubleL(6) = Bz_double - U_doubleL(7) = E_double - - U_doubleR(1) = rhoR_star - U_doubleR(2) = rhoR_star*s_M - U_doubleR(3) = rhoR_star*v_double - U_doubleR(4) = rhoR_star*w_double - U_doubleR(5) = By_double - U_doubleR(6) = Bz_double - U_doubleR(7) = E_double - - ! (11) Choose HLLD flux based on wave-speed regions + U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -3077,7 +3053,7 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array + ! (9) Reorder and write temporary variables to the flux array ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum From 5a042c71edb20d3e78e27ff8392c50409756a73b Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 01:30:38 -0400 Subject: [PATCH 26/58] cleaned up s_hllc_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 572 +++++++++------------------ 1 file changed, 197 insertions(+), 375 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 532cfcd59..e38bfcfab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1213,6 +1213,78 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux + ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -1289,15 +1361,6 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) @@ -1305,6 +1368,7 @@ contains !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -1329,91 +1393,75 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - + Re_R(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0._wp - + if (Re_size(i) > 0) Re_R(i) = 0._wp !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -1595,40 +1643,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -1694,7 +1709,6 @@ contains end do E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L @@ -1782,7 +1796,6 @@ contains ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp end do @@ -1802,53 +1815,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -1884,6 +1851,10 @@ contains gamma_L = 0._wp pi_inf_L = 0._wp qv_L = 0._wp + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then @@ -1893,30 +1864,6 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else - rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - end if - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) @@ -1925,12 +1872,20 @@ contains else if (num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) end do else + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) @@ -1942,38 +1897,25 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if end if E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L @@ -2237,54 +2179,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif + call s_compute_cylindrical_geometry_source_flux() end do end do end do @@ -2341,22 +2236,13 @@ contains qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - !$acc loop seq do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) end do end if @@ -2378,31 +2264,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -2459,67 +2333,63 @@ contains H_R = (E_R + pres_R)/rho_R else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R end if - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do end if H_L = (E_L + pres_L)/rho_L @@ -2706,55 +2576,7 @@ contains end if ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & - xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - + xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - - xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif - + call s_compute_cylindrical_geometry_source_flux() end do end do end do From b37e483db6b08d8d7899602cbc07c90df1476a24 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 02:27:42 -0400 Subject: [PATCH 27/58] cleaned up s_hll_riemann_solver redundancy --- src/simulation/m_riemann_solvers.fpp | 327 ++++++++++----------------- 1 file changed, 118 insertions(+), 209 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e38bfcfab..cc19ea4ab 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -474,31 +474,19 @@ contains !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if !$acc loop seq do q = 1, Re_size(i) Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + Re_R(i) end do - + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) end do end if @@ -512,13 +500,11 @@ contains call get_mixture_molecular_weight(Ys_L, MW_L) call get_mixture_molecular_weight(Ys_R, MW_R) - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) R_gas_L = gas_constant/MW_L R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L T_R = pres_R/rho_R/R_gas_R @@ -552,44 +538,39 @@ contains E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms H_L = (E_L + pres_L)/rho_L H_R = (E_R + pres_R)/rho_R - elseif (mhd .and. relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L - b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R - b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R - b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - - cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) - cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) - cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) - cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) - cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) - cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (mhd .and. .not. relativity) then - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + elseif (mhd) then + if (relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = dot_product(vel%L, B%L) + vdotB%R = dot_product(vel%R, B%R) + !acc loop seq + do i = 1, 3 + b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L + b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + end do + B2%L = sum(B%L**2._wp) + B2%R = sum(B%R**2._wp) + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + !acc loop seq + do i = 1, 3 + cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) + cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) + end do + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (.not. relativity) then + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + end if else E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R @@ -729,75 +710,52 @@ contains end do end if - ! Momentum - if (mhd .and. (.not. relativity)) then - ! Flux of rho*v_x in the ${XYZ}$ direction - ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & - - B%R(1)*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & - - B%L(1)*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & - /(s_M - s_P) - ! Flux of rho*v_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & - - B%R(2)*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & - - B%L(2)*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & - /(s_M - s_P) - ! Flux of rho*v_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & - - B%R(3)*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & - - B%L(3)*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! Flux of m_x in the ${XYZ}$ direction - ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(cm%R(1)*vel_R(norm_dir) & - - b4%R(1)/Ga%R*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(1)*vel_L(norm_dir) & - - b4%L(1)/Ga%L*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(1) - cm%R(1))) & - /(s_M - s_P) - ! Flux of m_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(cm%R(2)*vel_R(norm_dir) & - - b4%R(2)/Ga%R*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(2)*vel_L(norm_dir) & - - b4%L(2)/Ga%L*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(2) - cm%R(2))) & - /(s_M - s_P) - ! Flux of m_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(cm%R(3)*vel_R(norm_dir) & - - b4%R(3)/Ga%R*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(3)*vel_L(norm_dir) & - - b4%L(3)/Ga%L*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(3) - cm%R(3))) & - /(s_M - s_P) + ! Momentum and Energy fluxes + if (mhd) then + if (.not. relativity) then + ! Flux of rho*v_x in the ${XYZ}$ direction + ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + !acc loop seq + do i = 1, 3 + flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & + (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & + - B%R(i)*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + - B%L(i)*B%L(norm_dir) & + + dir_flg(i)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & + /(s_M - s_P) + end do + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + + elseif (relativity) then + do i = 1, 3 + ! Flux of m_x in the ${XYZ}$ direction + ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & + (s_M*(cm%R(i)*vel_R(norm_dir) & + - b4%R(i)/Ga%R*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(i)*vel_L(norm_dir) & + - b4%L(i)/Ga%L*B%L(norm_dir) & + + dir_flg(i)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(i) - cm%R(i))) & + /(s_M - s_P) + end do + ! energy flux = m_${XYZ}$ - mass flux + ! Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + end if elseif (bubbles_euler) then !$acc loop seq do i = 1, num_vels @@ -813,6 +771,13 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do + ! energy flux + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then !$acc loop seq do i = 1, num_vels @@ -829,6 +794,18 @@ contains - rho_R*vel_R(dir_idx(i)))) & /(s_M - s_P) end do + ! energy flux + real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp + !acc loop seq + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) else !$acc loop seq do i = 1, num_vels @@ -844,65 +821,7 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do - end if - - ! Energy - if (mhd .and. (.not. relativity)) then - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - !TODO: simplify this so it's not split into 3 - if (num_dims == 1) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 2) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 3) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & - - (tau_e_R(dir_idx_tau(3))*vel_R(dir_idx(3)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2))) & - - (tau_e_L(dir_idx_tau(3))*vel_L(dir_idx(3)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - end if - else + ! energy flux flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & @@ -988,34 +907,25 @@ contains if (mhd) then if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. ! B_y flux = v_x * B_y - v_y * Bx0 - flux_rsx_vf(j, k, l, B_idx%beg) = (s_M*(vel_R(1)*B%R(2) - vel_R(2)*Bx0) & - - s_P*(vel_L(1)*B%L(2) - vel_L(2)*Bx0) + s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) - ! B_z flux = v_x * B_z - v_z * Bx0 - flux_rsx_vf(j, k, l, B_idx%beg + 1) = (s_M*(vel_R(1)*B%R(3) - vel_R(3)*Bx0) & - - s_P*(vel_L(1)*B%L(3) - vel_L(3)*Bx0) + s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) - + !acc loop seq + do i = 0, 1 + flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & + + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + end do else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = (1 - dir_flg(1))*( & - s_M*(vel_R(dir_idx(1))*B%R(1) - vel_R(1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(1) - vel_L(1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(1) - B%R(1)))/(s_M - s_P) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = (1 - dir_flg(2))*( & - s_M*(vel_R(dir_idx(1))*B%R(2) - vel_R(2)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(2) - vel_L(2)*B%L(norm_dir)) + & - s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) = (1 - dir_flg(3))*( & - s_M*(vel_R(dir_idx(1))*B%R(3) - vel_R(3)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(3) - vel_L(3)*B%L(norm_dir)) + & - s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) - + !$acc loop seq + do i = 0, 2 + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & + s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + end do end if - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp end if @@ -1050,7 +960,6 @@ contains end do end if #:endif - end do end do end do From 53caf2e0668ab446295576e45c62867ad40138d7 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 12:41:00 -0400 Subject: [PATCH 28/58] fixed s_compute_wave_speed subroutine --- src/simulation/m_riemann_solvers.fpp | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index cc19ea4ab..627665ac5 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,8 +668,8 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S) @@ -1402,8 +1402,8 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S) @@ -1637,8 +1637,8 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) @@ -1963,8 +1963,8 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) @@ -2329,8 +2329,8 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg & - c_L, c_R, c_avg, c_fast, G_L, G_R, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, & s_L, s_R, s_S, s_M, s_P) From 31fd75ce1ebc7fdb00aeb9e9c255d58b1d583183 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 13:03:57 -0400 Subject: [PATCH 29/58] removed dir_idx indexing from the definition of wave speed subroutine --- src/simulation/m_riemann_solvers.fpp | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 627665ac5..fe906513a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,9 +668,9 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & @@ -1402,9 +1402,9 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1637,10 +1637,10 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1963,10 +1963,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2329,10 +2329,10 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S, s_M, s_P) + tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From 2dba774be6c59640dc583b50cced3dd0484caa45 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 14:37:41 -0400 Subject: [PATCH 30/58] dir_idx re-added --- src/simulation/m_riemann_solvers.fpp | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index fe906513a..16c568351 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -668,9 +668,9 @@ contains end do end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & @@ -1402,9 +1402,9 @@ contains end if ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1637,9 +1637,9 @@ contains call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & vel_avg_rms, 0._wp, c_avg) - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -1963,9 +1963,9 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) @@ -2329,9 +2329,9 @@ contains @:compute_low_Mach_correction() end if - call s_compute_wave_speed(wave_speeds, vel_L(dir_idx(1)), vel_R(dir_idx(1)), pres_L, pres_R, rho_L, rho_R, rho_avg, & + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L(dir_idx_tau(1)), tau_e_R(dir_idx_tau(1)), & + tau_e_L, tau_e_R, & s_L, s_R, s_S) ! goes with q_star_L/R = xi_L/R * (variable) From 3b87db9301b3cd73241b8ab96e08327fb5c35102 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 16:59:20 -0400 Subject: [PATCH 31/58] fixed syntax errors --- src/simulation/m_riemann_solvers.fpp | 292 ++++++++++++++------------- 1 file changed, 154 insertions(+), 138 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 16c568351..9bce3682d 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -284,6 +284,7 @@ contains type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -330,7 +331,7 @@ contains real(wp) :: alpha_L_sum, alpha_R_sum real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag + type(riemann_states) :: c_fast, pres_mag, vel type(riemann_states_vec3) :: B type(riemann_states) :: Ga ! Gamma (Lorentz factor) @@ -542,13 +543,15 @@ contains if (relativity) then Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = dot_product(vel%L, B%L) - vdotB%R = dot_product(vel%R, B%R) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + !acc loop seq do i = 1, 3 - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L + b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R end do + B2%L = sum(B%L**2._wp) B2%R = sum(B%R**2._wp) pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) @@ -670,8 +673,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -795,7 +798,6 @@ contains /(s_M - s_P) end do ! energy flux - real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp !acc loop seq do i = 1, num_dims flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) @@ -1121,81 +1123,7 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi - - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions + type(riemann_states) :: c_fast, vel call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -1321,7 +1249,7 @@ contains E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) + if (hypoelasticity .or. hyperelasticity) then G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids @@ -1404,8 +1332,8 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1639,8 +1567,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1965,8 +1893,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2249,7 +2177,7 @@ contains end if ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) + if (hypoelasticity .or. hyperelasticity) then G_L = 0_wp; G_R = 0_wp !$acc loop seq do i = 1, num_fluids @@ -2331,8 +2259,8 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, & - s_L, s_R, s_S) + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2534,6 +2462,80 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux + ! end contains + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions end subroutine s_hllc_riemann_solver @@ -2580,7 +2582,6 @@ contains real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - real ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction @@ -2590,50 +2591,6 @@ contains real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double integer :: i, j, k, l - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho, U(2) = rho*vel(1), U(3) = rho*vel(2), U(4) = rho*vel(3) - U(5) = B(2), U(6) = B(3), U(7) = E - ! Compute the flux vector - F(1) = U(2), F(2) = U(2)*vel(1) - B(1)*B(1) + pTot, F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3), F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1), F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star, U_star(2) = rho_star*s_M, U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3), U_star(5) = B(2), U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -2817,6 +2774,65 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) + + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables + ! end contains end subroutine s_hlld_riemann_solver !> The computation of parameters, the allocation of memory, From 0df82ab0d5ee225230de5e20e609b7d1fdc1eebb Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 22:35:50 -0400 Subject: [PATCH 32/58] dir_idx(_tau) not recognized yet albeit global variables thus just passed them in the calls --- src/simulation/m_riemann_solvers.fpp | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 9bce3682d..ca5dcc2d8 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -674,7 +674,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -1333,7 +1333,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1568,7 +1568,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1894,7 +1894,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2260,7 +2260,7 @@ contains call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P) + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) From a0b5007af553dead55601be22af6871985b6b141 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Mon, 2 Jun 2025 22:44:52 -0400 Subject: [PATCH 33/58] Prettifying --- src/simulation/m_riemann_solvers.fpp | 346 +++++++++++++-------------- 1 file changed, 173 insertions(+), 173 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index ca5dcc2d8..625268c76 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -672,9 +672,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + (5e-1_wp - sign(5e-1_wp, s_L)) & @@ -722,19 +722,19 @@ contains do i = 1, 3 flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & + - B%R(i)*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - B%L(i)*B%L(norm_dir) & + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & + + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & /(s_M - s_P) end do ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) elseif (relativity) then @@ -743,20 +743,20 @@ contains ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & + - b4%R(i)/Ga%R*B%R(norm_dir) & + + dir_flg(i)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(i)*vel_L(norm_dir) & - b4%L(i)/Ga%L*B%L(norm_dir) & + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & + + s_M*s_P*(cm%L(i) - cm%R(i))) & /(s_M - s_P) end do ! energy flux = m_${XYZ}$ - mass flux ! Hard-coded for single-component for now flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & /(s_M - s_P) end if elseif (bubbles_euler) then @@ -803,11 +803,11 @@ contains flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) else !$acc loop seq do i = 1, num_vels @@ -923,9 +923,9 @@ contains !$acc loop seq do i = 0, 2 flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & - s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) end do end if flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp @@ -1250,12 +1250,12 @@ contains ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do if (hypoelasticity) then !$acc loop seq do i = 1, strxe - strxb + 1 @@ -1331,9 +1331,9 @@ contains ! COMPUTING THE DIRECT WAVE SPEEDS call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1566,9 +1566,9 @@ contains vel_avg_rms, 0._wp, c_avg) call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -1892,9 +1892,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2178,12 +2178,12 @@ contains ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do if (hypoelasticity) then !$acc loop seq do i = 1, strxe - strxb + 1 @@ -2258,9 +2258,9 @@ contains end if call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) ! goes with q_star_L/R = xi_L/R * (variable) ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) @@ -2462,77 +2462,77 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero + contains + subroutine s_compute_cylindrical_geometry_source_flux() + !$acc routine seq + ! This subroutine computes the cylindrical geometry source fluxes + #:if (NORM_DIR == 2) + if (cyl_coord) then + if (model_eqns == 3) then + !Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + end if + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + if (model_eqns == 3) then + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + else + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end subroutine s_compute_cylindrical_geometry_source_flux ! end contains ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions @@ -2703,9 +2703,9 @@ contains ! (5) Compute left/right state vectors and fluxes call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & - U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & - U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star @@ -2721,7 +2721,7 @@ contains U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - + ! (7) Compute the rotational (Alfvén) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) @@ -2775,63 +2775,63 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables (side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho - U(2) = rho*vel(1) - U(3) = rho*vel(2) - U(4) = rho*vel(3) - U(5) = B(2) - U(6) = B(3) - U(7) = E - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3) - F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star - U_star(2) = rho_star*s_M - U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3) - U_star(5) = B(2) - U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables ! end contains end subroutine s_hlld_riemann_solver From f51210bf856002d760f5d5500c1f6fa2a98b0f8f Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 00:51:23 -0400 Subject: [PATCH 34/58] cleand up redundant loops in s_populate_riemann_states_variables_buffers --- src/simulation/m_riemann_solvers.fpp | 367 ++++++--------------------- 1 file changed, 75 insertions(+), 292 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 625268c76..f3f3f9cf9 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3000,15 +3000,31 @@ contains integer :: i, j, k, l !< Generic loop iterator + pointer :: qL_prim_rs_vf, dqL_prim_d_vf + pointer :: qR_prim_rs_vf, dqR_prim_d_vf + integer :: end_val, bc_beg, bc_end + if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf; qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf; dqR_prim_d_vf => dqR_prim_dx_vf elseif (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + qL_prim_rs_vf => qL_prim_rsy_vf; qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf; dqR_prim_d_vf => dqR_prim_dy_vf + end_val = n else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + qL_prim_rs_vf => qL_prim_rsz_vf; qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf; dqR_prim_d_vf => dqR_prim_dz_vf + end_val = p end if !$acc update device(is1, is2, is3) @@ -3027,317 +3043,84 @@ contains !$acc update device(isx, isy, isz) ! for stuff in the same module !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - ! Population of Buffers in x-direction - if (norm_dir == 1) then - - if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(-1, k, l, i) = & - qR_prim_rsx_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dx_vf(i)%sf(-1, k, l) = & - dqR_prim_dx_vf(i)%sf(0, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dy_vf(i)%sf(-1, k, l) = & - dqR_prim_dy_vf(i)%sf(0, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dz_vf(i)%sf(-1, k, l) = & - dqR_prim_dz_vf(i)%sf(0, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(m + 1, k, l, i) = & - qL_prim_rsx_vf(m, k, l, i) - end do + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) end do end do - - if (viscous) then - + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) do i = momxb, momxe do l = isz%beg, isz%end do k = isy%beg, isy%end - - dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dx_vf(i)%sf(m, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dy_vf(i)%sf(m, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dz_vf(i)%sf(m, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - ! END: Population of Buffers in x-direction - - ! Population of Buffers in y-direction - elseif (norm_dir == 2) then - - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsy_vf(-1, k, l, i) = & - qR_prim_rsy_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, -1, l) = & - dqR_prim_dx_vf(i)%sf(j, 0, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, -1, l) = & - dqR_prim_dy_vf(i)%sf(j, 0, l) + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, -1, l) = & - dqR_prim_dz_vf(i)%sf(j, 0, l) - end do - end do - end do - end if - - end if - end if - - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsy_vf(n + 1, k, l, i) = & - qL_prim_rsy_vf(n, k, l, i) - end do + end if + + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dx_vf(i)%sf(j, n, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dy_vf(i)%sf(j, n, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dz_vf(i)%sf(j, n, l) - end do - end do - end do - end if - - end if - - end if - ! END: Population of Buffers in y-direction - - ! Population of Buffers in z-direction - else - - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsz_vf(-1, k, l, i) = & - qR_prim_rsz_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = & - dqR_prim_dx_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe + do i = momxb, momxe + do l = isz%beg, isz%end do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = & - dqR_prim_dy_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = & - dqR_prim_dz_vf(i)%sf(j, k, 0) - end do - end do - end do - end if - - end if - - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsz_vf(p + 1, k, l, i) = & - qL_prim_rsz_vf(p, k, l, i) + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if end do end do end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dx_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dy_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dz_vf(i)%sf(j, k, p) - end do - end do - end do - end if - end if - end if - ! END: Population of Buffers in z-direction end subroutine s_populate_riemann_states_variables_buffers From 483d116ebb013e9a652bec422a937e77ba059f17 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 18:50:37 -0400 Subject: [PATCH 35/58] corrected pointer implementation in s_populate_riemann_states_variables_buffers --- src/simulation/m_riemann_solvers.fpp | 34 +++++++++++++++++----------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index f3f3f9cf9..72409866b 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2986,45 +2986,53 @@ contains qR_prim_vf, & norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:,:,:,:), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & dqL_prim_dy_vf, dqR_prim_dy_vf, & dqL_prim_dz_vf, dqR_prim_dz_vf, & qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l !< Generic loop iterator - pointer :: qL_prim_rs_vf, dqL_prim_d_vf - pointer :: qR_prim_rs_vf, dqR_prim_d_vf - integer :: end_val, bc_beg, bc_end - if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) bc_beg = bc_x%beg; bc_end = bc_x%end end_val = m - qL_prim_rs_vf => qL_prim_rsx_vf; qR_prim_rs_vf => qR_prim_rsx_vf - dqL_prim_d_vf => dqL_prim_dx_vf; dqR_prim_d_vf => dqR_prim_dx_vf - elseif (norm_dir == 2) then + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) bc_beg = bc_y%beg; bc_end = bc_y%end - qL_prim_rs_vf => qL_prim_rsy_vf; qR_prim_rs_vf => qR_prim_rsy_vf - dqL_prim_d_vf => dqL_prim_dy_vf; dqR_prim_d_vf => dqR_prim_dy_vf end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) bc_beg = bc_z%beg; bc_end = bc_z%end - qL_prim_rs_vf => qL_prim_rsz_vf; qR_prim_rs_vf => qR_prim_rsz_vf - dqL_prim_d_vf => dqL_prim_dz_vf; dqR_prim_d_vf => dqR_prim_dz_vf end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf end if !$acc update device(is1, is2, is3) From 334720f956bf05217182ef43f68319555a13cf66 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 19:41:46 -0400 Subject: [PATCH 36/58] refactored s_initialize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 84 ++++++---------------------- 1 file changed, 16 insertions(+), 68 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 72409866b..1917c1fb7 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3163,97 +3163,45 @@ contains type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l ! Generic loop iterators - ! Reshaping Inputted Data in x-direction - if (norm_dir == 1) then - - if (viscous .or. (surface_tension)) then - + if (viscous .or. (surface_tension)) then !$acc parallel loop collapse(4) gang vector default(present) do i = momxb, E_idx do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in y-direction - elseif (norm_dir == 2) then - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in z-direction - else - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = 0._wp + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if end do end do end do end do end if - if (qbmm) then + if (qbmm) then !$acc parallel loop collapse(4) gang vector default(present) do i = 1, 4 do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end + 1 - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if end do end do end do end do end if - end if end subroutine s_initialize_riemann_solver From 3986b6f218378d3b91ff58006f1c90db04f71062 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:06:29 -0400 Subject: [PATCH 37/58] refactored s_finalize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 143 +++++++-------------------- 1 file changed, 38 insertions(+), 105 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 1917c1fb7..7bc2b6c27 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3598,144 +3598,77 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - end do - end do - end do - end do - - if (cyl_coord) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(advxb)%sf(k, j, l) = & flux_src_rsy_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - end do + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - end if - ! Reshaping Outputted Data in z-direction + ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end - - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - end do - end do - end do - end do - if (grid_geometry == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do - end do - end do - end do - end if - - !$acc parallel loop collapse(3) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) end do end do end do - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - end do - end do - end do - end do - - end if elseif (norm_dir == 1) then !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end + + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end do + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) end do end do end do - end if + end do end if end subroutine s_finalize_riemann_solver From b94acd6cf4f4fbc54d028c45d705310078407639 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:19:55 -0400 Subject: [PATCH 38/58] finished formatting --- src/simulation/m_riemann_solvers.fpp | 868 +++++++++++++-------------- 1 file changed, 434 insertions(+), 434 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 7bc2b6c27..bfbb17f69 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2987,14 +2987,14 @@ contains norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - real(wp), dimension(:,:,:,:), pointer :: qL_prim_rs_vf, qR_prim_rs_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf type(scalar_field), & dimension(:), & pointer :: dqL_prim_d_vf, dqR_prim_d_vf @@ -3062,35 +3062,35 @@ contains end do end do if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) - if (n > 0) then - dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) - end if - end if - else if (norm_dir == 2) then - dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) - dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) if (p > 0) then - dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) end if - else - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) end if - end do + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do + end do end if end if - + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end !$acc parallel loop collapse(3) gang vector default(present) do i = 1, sys_size @@ -3166,47 +3166,47 @@ contains ! Reshaping Inputted Data in x-direction if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = 0._wp - else if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if - end do + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if end do end do end do - end if + end do + end if if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - if (norm_dir == 1) then - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - else if (norm_dir == 2) then - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - else if (norm_dir == 3) then - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end if - end do + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if end do end do end do - end if + end do + end if end if - end subroutine s_initialize_riemann_solver + end subroutine s_initialize_riemann_solver - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives !! and cylindrical geometric factors, then updates `flux_src_vf`. !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). @@ -3223,153 +3223,153 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if + if (num_dims > 2) then + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp + end if + end do + + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff end if - end do - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select - - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff - if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff - end if + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + if (num_dims > 1) then + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + end if if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + end do + end if - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if + end do end do end do - end do - !$acc end parallel loop + !$acc end parallel loop - end subroutine s_compute_cylindrical_viscous_source_flux + end subroutine s_compute_cylindrical_viscous_source_flux - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. !! Calculates averaged velocity gradients, gets Re and interface velocities, !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). @@ -3385,195 +3385,195 @@ contains !! @param[in] ix X-direction loop bounds (int_bounds_info). !! @param[in] iy Y-direction loop bounds (int_bounds_info). !! @param[in] iz Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - end do - - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) - end do + subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + + divergence_v = 0.0_wp do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) end do - end if - if (shear_stress) then - current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + if (shear_stress) then + current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do - end if + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - if (bulk_stress) then - current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + if (bulk_stress) then + current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do - end if + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do + end if + end do end do end do - end do - !$acc end parallel loop + !$acc end parallel loop - end subroutine s_compute_cartesian_viscous_source_flux + end subroutine s_compute_cartesian_viscous_source_flux - !> @brief Calculates shear stress tensor components. + !> @brief Calculates shear stress tensor components. !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). !! @param[in] Re_shear Shear Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. - tau_shear_out = 0.0_wp + tau_shear_out = 0.0_wp - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear - end if + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do end do - end do - end subroutine s_calculate_shear_stress_tensor + end subroutine s_calculate_shear_stress_tensor - !> @brief Calculates bulk stress tensor components (diagonal only). + !> @brief Calculates bulk stress tensor components (diagonal only). !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. !! @param[in] Re_bulk Bulk Reynolds number. !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp + tau_bulk_out = 0.0_wp - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do - end subroutine s_calculate_bulk_stress_tensor + end subroutine s_calculate_bulk_stress_tensor - !> Deallocation and/or disassociation procedures that are + !> Deallocation and/or disassociation procedures that are !! needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes @@ -3582,42 +3582,42 @@ contains !! @param ix Index bounds in first coordinate direction !! @param iy Index bounds in second coordinate direction !! @param iz Index bounds in third coordinate direction - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if + end do end do end do end do - end do - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(4) gang vector default(present) do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end @@ -3631,88 +3631,88 @@ contains flux_gsrc_rsz_vf(j, k, l, i) end if end do - end do - end do - end do - - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) end do end do end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe + + elseif (norm_dir == 1) then + !$acc parallel loop collapse(4) gang vector default(present) do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do - end do - end if - end subroutine s_finalize_riemann_solver + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) + end do + end do + end do + end do + end if - !> Module deallocation and/or disassociation procedures - subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solver - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if + !> Module deallocation and/or disassociation procedures + subroutine s_finalize_riemann_solvers_module - if (n == 0) return + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if + if (n == 0) return - if (p == 0) return + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if + if (p == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if - end subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solvers_module -end module m_riemann_solvers + end module m_riemann_solvers From f21735795814fb112efb30bc997099c0fb522386 Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Tue, 3 Jun 2025 20:58:00 -0400 Subject: [PATCH 39/58] pushing to the test suite --- src/simulation/m_riemann_solvers.fpp | 845 ++++++++++++++------------- 1 file changed, 423 insertions(+), 422 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index bfbb17f69..25daa005e 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3202,11 +3202,10 @@ contains end do end do end if - end if - end subroutine s_initialize_riemann_solver + end subroutine s_initialize_riemann_solver - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives !! and cylindrical geometric factors, then updates `flux_src_vf`. !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). @@ -3223,357 +3222,357 @@ contains !! @param[in] ix Global X-direction loop bounds (int_bounds_info). !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if - if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp - end if - end do - - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select + subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp end if + end do - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp - - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select - - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + if (num_dims > 2) then + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + end if - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cylindrical_viscous_source_flux - - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - !! @param[in] ix X-direction loop bounds (int_bounds_info). - !! @param[in] iy Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s end if if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s end if - end do + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) end do + end if - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) - end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) - end do - end if + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b - if (shear_stress) then - current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cylindrical_viscous_source_flux + + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !! Calculates averaged velocity gradients, gets Re and interface velocities, + !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !! @param[in] ix X-direction loop bounds (int_bounds_info). + !! @param[in] iy Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Z-direction loop bounds (int_bounds_info). + subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) end if - - if (bulk_stress) then - current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) end if + end do + divergence_v = 0.0_wp + do i_dim = 1, num_dims + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) end do - end do - end do - !$acc end parallel loop - end subroutine s_compute_cartesian_viscous_source_flux + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if - !> @brief Calculates shear stress tensor components. - !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear - !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). - !! @param[in] Re_shear Shear Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq + if (shear_stress) then + current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - implicit none + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. + if (bulk_stress) then + current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - tau_shear_out = 0.0_wp + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do end if + end do end do + end do + !$acc end parallel loop + + end subroutine s_compute_cartesian_viscous_source_flux + + !> @brief Calculates shear stress tensor components. + !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear + !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). + !! @param[in] Re_shear Shear Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. + + tau_shear_out = 0.0_wp + + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do + end do - end subroutine s_calculate_shear_stress_tensor + end subroutine s_calculate_shear_stress_tensor - !> @brief Calculates bulk stress tensor components (diagonal only). - !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. - !! @param[in] Re_bulk Bulk Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq + !> @brief Calculates bulk stress tensor components (diagonal only). + !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. + !! @param[in] Re_bulk Bulk Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq - implicit none + implicit none - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp + tau_bulk_out = 0.0_wp - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do - end subroutine s_calculate_bulk_stress_tensor + end subroutine s_calculate_bulk_stress_tensor - !> Deallocation and/or disassociation procedures that are + !> Deallocation and/or disassociation procedures that are !! needed to finalize the selected Riemann problem solver !! @param flux_vf Intercell fluxes !! @param flux_src_vf Intercell source fluxes @@ -3582,137 +3581,139 @@ contains !! @param ix Index bounds in first coordinate direction !! @param iy Index bounds in second coordinate direction !! @param iz Index bounds in third coordinate direction - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterators + integer :: i, j, k, l !< Generic loop iterators - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if - end do + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - if (grid_geometry == 3) then - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end if - end do + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(4) gang vector default(present) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do end do end do + end do - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do + elseif (norm_dir == 1) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) end do end do end do + end do + end if - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end do - end do - end do - end do + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) end if + end do + end do + end do + end do + end if - end subroutine s_finalize_riemann_solver + end subroutine s_finalize_riemann_solver - !> Module deallocation and/or disassociation procedures - subroutine s_finalize_riemann_solvers_module + !> Module deallocation and/or disassociation procedures + subroutine s_finalize_riemann_solvers_module - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if - if (n == 0) return + if (n == 0) return - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if - if (p == 0) return + if (p == 0) return - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if - end subroutine s_finalize_riemann_solvers_module + end subroutine s_finalize_riemann_solvers_module - end module m_riemann_solvers +end module m_riemann_solvers From 711c18741ba43ed58e751dd97da083085958c567 Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Thu, 5 Jun 2025 03:23:21 -0400 Subject: [PATCH 40/58] new changes --- src/common/m_variables_conversion.fpp | 3672 ++++++------ src/simulation/m_riemann_solvers.fpp | 7611 +++++++++++++------------ 2 files changed, 5728 insertions(+), 5555 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index f1dbe6ee8..0e6f2406c 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1,1836 +1,1836 @@ -!> -!! @file m_variables_conversion.f90 -!! @brief Contains module m_variables_conversion - -#:include 'macros.fpp' -#:include 'case.fpp' - -!> @brief This module consists of subroutines used in the conversion of the -!! conservative variables into the primitive ones and vice versa. In -!! addition, the module also contains the subroutines used to obtain -!! the mixture variables and the subroutines used to compute pressure. -module m_variables_conversion - - use m_derived_types !< Definitions of the derived types - - use m_global_parameters !< Definitions of the global parameters - - use m_mpi_proxy !< Message passing interface (MPI) module proxy - - use m_helper_basic !< Functions to compare floating point numbers - - use m_helper - - use m_thermochem, only: & - num_species, get_temperature, get_pressure, gas_constant, & - get_mixture_molecular_weight, get_mixture_energy_mass - - implicit none - - private; - public :: s_initialize_variables_conversion_module, & - s_initialize_pb, & - s_initialize_mv, & - s_convert_to_mixture_variables, & - s_convert_mixture_to_mixture_variables, & - s_convert_species_to_mixture_variables_bubbles, & - s_convert_species_to_mixture_variables_bubbles_acc, & - s_convert_species_to_mixture_variables, & - s_convert_species_to_mixture_variables_acc, & - s_convert_conservative_to_primitive_variables, & - s_convert_primitive_to_conservative_variables, & - s_convert_primitive_to_flux_variables, & - s_compute_pressure, & -#ifndef MFC_PRE_PROCESS - s_compute_speed_of_sound, & - s_compute_fast_magnetosonic_speed, & - s_compute_wave_speed, & -#endif - s_finalize_variables_conversion_module - - !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables -#ifndef MFC_SIMULATION - real(wp), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps - !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) -#endif - - real(wp), allocatable, dimension(:) :: Gs - integer, allocatable, dimension(:) :: bubrs - real(wp), allocatable, dimension(:, :) :: Res - !$acc declare create(bubrs, Gs, Res) - - integer :: is1b, is2b, is3b, is1e, is2e, is3e - !$acc declare create(is1b, is2b, is3b, is1e, is2e, is3e) - - real(wp), allocatable, dimension(:, :, :), public :: rho_sf !< Scalar density function - real(wp), allocatable, dimension(:, :, :), public :: gamma_sf !< Scalar sp. heat ratio function - real(wp), allocatable, dimension(:, :, :), public :: pi_inf_sf !< Scalar liquid stiffness function - real(wp), allocatable, dimension(:, :, :), public :: qv_sf !< Scalar liquid energy reference function - -contains - - !> Dispatch to the s_convert_mixture_to_mixture_variables - !! and s_convert_species_to_mixture_variables subroutines. - !! Replaces a procedure pointer. - !! @param q_vf Conservative or primitive variables - !! @param i First-coordinate cell index - !! @param j First-coordinate cell index - !! @param k First-coordinate cell index - !! @param rho Density - !! @param gamma Specific heat ratio function - !! @param pi_inf Liquid stiffness function - !! @param qv Fluid reference energy - subroutine s_convert_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - integer, intent(in) :: i, j, k - real(wp), intent(out), target :: rho, gamma, pi_inf, qv - real(wp), optional, dimension(2), intent(out) :: Re_K - real(wp), optional, intent(out) :: G_K - real(wp), optional, dimension(num_fluids), intent(in) :: G - - if (model_eqns == 1) then ! Gamma/pi_inf model - call s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - - else if (bubbles_euler) then - call s_convert_species_to_mixture_variables_bubbles(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - else - ! Volume fraction model - call s_convert_species_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - end if - - end subroutine s_convert_to_mixture_variables - - !> This procedure conditionally calculates the appropriate pressure - !! @param energy Energy - !! @param alf Void Fraction - !! @param dyn_p Dynamic Pressure - !! @param pi_inf Liquid Stiffness - !! @param gamma Specific Heat Ratio - !! @param rho Density - !! @param qv fluid reference energy - !! @param pres Pressure to calculate - !! @param stress Shear Stress - !! @param mom Momentum - subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, stress, mom, G, pres_mag) - -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_compute_pressure -#else - !$acc routine seq -#endif - - real(wp), intent(in) :: energy, alf - real(wp), intent(in) :: dyn_p - real(wp), intent(in) :: pi_inf, gamma, rho, qv - real(wp), intent(out) :: pres - real(wp), intent(inout) :: T - real(wp), intent(in), optional :: stress, mom, G, pres_mag - - ! Chemistry - real(wp), dimension(1:num_species), intent(in) :: rhoYks - real(wp) :: E_e - real(wp) :: e_Per_Kg, Pdyn_Per_Kg - real(wp) :: T_guess - real(wp), dimension(1:num_species) :: Y_rs - - integer :: s !< Generic loop iterator - - #:if not chemistry - ! Depending on model_eqns and bubbles_euler, the appropriate procedure - ! for computing pressure is targeted by the procedure pointer - - if (mhd) then - pres = (energy - dyn_p - pi_inf - qv - pres_mag)/gamma - elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then - pres = (energy - dyn_p - pi_inf - qv)/gamma - else if ((model_eqns /= 4) .and. bubbles_euler) then - pres = ((energy - dyn_p)/(1._wp - alf) - pi_inf - qv)/gamma - else - pres = (pref + pi_inf)* & - (energy/ & - (rhoref*(1 - alf)) & - )**(1/gamma + 1) - pi_inf - end if - - if (hypoelasticity .and. present(G)) then - ! calculate elastic contribution to Energy - E_e = 0._wp - do s = stress_idx%beg, stress_idx%end - if (G > 0) then - E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) - ! Double for shear stresses - if (any(s == shear_indices)) then - E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) - end if - end if - end do - - pres = ( & - energy - & - 0.5_wp*(mom**2._wp)/rho - & - pi_inf - qv - E_e & - )/gamma - - end if - - #:else - - Y_rs(:) = rhoYks(:)/rho - e_Per_Kg = energy/rho - Pdyn_Per_Kg = dyn_p/rho - - T_guess = T - - call get_temperature(e_Per_Kg - Pdyn_Per_Kg, T_guess, Y_rs, .true., T) - call get_pressure(rho, T, Y_rs, pres) - - #:endif - - end subroutine s_compute_pressure - - !> This subroutine is designed for the gamma/pi_inf model - !! and provided a set of either conservative or primitive - !! variables, transfers the density, specific heat ratio - !! function and the liquid stiffness function from q_vf to - !! rho, gamma and pi_inf. - !! @param q_vf conservative or primitive variables - !! @param i cell index to transfer mixture variables - !! @param j cell index to transfer mixture variables - !! @param k cell index to transfer mixture variables - !! @param rho density - !! @param gamma specific heat ratio function - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy - subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - integer, intent(in) :: i, j, k - - real(wp), intent(out), target :: rho - real(wp), intent(out), target :: gamma - real(wp), intent(out), target :: pi_inf - real(wp), intent(out), target :: qv - - real(wp), optional, dimension(2), intent(out) :: Re_K - - real(wp), optional, intent(out) :: G_K - real(wp), optional, dimension(num_fluids), intent(in) :: G - - ! Transferring the density, the specific heat ratio function and the - ! liquid stiffness function, respectively - rho = q_vf(1)%sf(i, j, k) - gamma = q_vf(gamma_idx)%sf(i, j, k) - pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) - qv = 0._wp ! keep this value nill for now. For future adjustment - - ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated -#ifdef MFC_POST_PROCESS - rho_sf(i, j, k) = rho - gamma_sf(i, j, k) = gamma - pi_inf_sf(i, j, k) = pi_inf - qv_sf(i, j, k) = qv -#endif - - end subroutine s_convert_mixture_to_mixture_variables - - !> This procedure is used alongside with the gamma/pi_inf - !! model to transfer the density, the specific heat ratio - !! function and liquid stiffness function from the vector - !! of conservative or primitive variables to their scalar - !! counterparts. Specifically designed for when subgrid bubbles_euler - !! must be included. - !! @param q_vf primitive variables - !! @param j Cell index - !! @param k Cell index - !! @param l Cell index - !! @param rho density - !! @param gamma specific heat ratio - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy - subroutine s_convert_species_to_mixture_variables_bubbles(q_vf, j, k, l, & - rho, gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - - integer, intent(in) :: j, k, l - - real(wp), intent(out), target :: rho - real(wp), intent(out), target :: gamma - real(wp), intent(out), target :: pi_inf - real(wp), intent(out), target :: qv - - real(wp), optional, dimension(2), intent(out) :: Re_K - real(wp), optional, intent(out) :: G_K - real(wp), optional, dimension(num_fluids), intent(in) :: G - - integer :: i, q - real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K - - ! Constraining the partial densities and the volume fractions within - ! their physical bounds to make sure that any mixture variables that - ! are derived from them result within the limits that are set by the - ! fluids physical parameters that make up the mixture - do i = 1, num_fluids - alpha_rho_K(i) = q_vf(i)%sf(j, k, l) - alpha_K(i) = q_vf(advxb + i - 1)%sf(j, k, l) - end do - - if (mpp_lim) then - - do i = 1, num_fluids - alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) - alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) - end do - - alpha_K = alpha_K/max(sum(alpha_K), 1e-16_wp) - - end if - - ! Performing the transfer of the density, the specific heat ratio - ! function as well as the liquid stiffness function, respectively - - if (model_eqns == 4) then - rho = q_vf(1)%sf(j, k, l) - gamma = fluid_pp(1)%gamma !qK_vf(gamma_idx)%sf(i,j,k) - pi_inf = fluid_pp(1)%pi_inf !qK_vf(pi_inf_idx)%sf(i,j,k) - qv = fluid_pp(1)%qv - else if ((model_eqns == 2) .and. bubbles_euler) then - rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp - - if (mpp_lim .and. (num_fluids > 2)) then - do i = 1, num_fluids - rho = rho + q_vf(i)%sf(j, k, l) - gamma = gamma + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%gamma - pi_inf = pi_inf + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%pi_inf - qv = qv + q_vf(i)%sf(j, k, l)*fluid_pp(i)%qv - end do - else if (num_fluids == 2) then - rho = q_vf(1)%sf(j, k, l) - gamma = fluid_pp(1)%gamma - pi_inf = fluid_pp(1)%pi_inf - qv = fluid_pp(1)%qv - else if (num_fluids > 2) then - !TODO: This may need fixing for hypo + bubbles_euler - do i = 1, num_fluids - 1 !leave out bubble part of mixture - rho = rho + q_vf(i)%sf(j, k, l) - gamma = gamma + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%gamma - pi_inf = pi_inf + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%pi_inf - qv = qv + q_vf(i)%sf(j, k, l)*fluid_pp(i)%qv - end do - ! rho = qK_vf(1)%sf(j,k,l) - ! gamma_K = fluid_pp(1)%gamma - ! pi_inf_K = fluid_pp(1)%pi_inf - else - rho = q_vf(1)%sf(j, k, l) - gamma = fluid_pp(1)%gamma - pi_inf = fluid_pp(1)%pi_inf - qv = fluid_pp(1)%qv - end if - end if - -#ifdef MFC_SIMULATION - ! Computing the shear and bulk Reynolds numbers from species analogs - if (viscous) then - if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 - do i = 1, 2 - - Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp - - do q = 1, Re_size(i) - Re_K(i) = (1 - alpha_K(Re_idx(i, q)))/fluid_pp(Re_idx(i, q))%Re(i) & - + Re_K(i) - end do - - Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) - - end do - end if - end if -#endif - - ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated -#ifdef MFC_POST_PROCESS - rho_sf(j, k, l) = rho - gamma_sf(j, k, l) = gamma - pi_inf_sf(j, k, l) = pi_inf - qv_sf(j, k, l) = qv -#endif - - end subroutine s_convert_species_to_mixture_variables_bubbles - - !> This subroutine is designed for the volume fraction model - !! and provided a set of either conservative or primitive - !! variables, computes the density, the specific heat ratio - !! function and the liquid stiffness function from q_vf and - !! stores the results into rho, gamma and pi_inf. - !! @param q_vf primitive variables - !! @param k Cell index - !! @param l Cell index - !! @param r Cell index - !! @param rho density - !! @param gamma specific heat ratio - !! @param pi_inf liquid stiffness - !! @param qv fluid reference energy - subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, & - gamma, pi_inf, qv, Re_K, G_K, G) - - type(scalar_field), dimension(sys_size), intent(in) :: q_vf - - integer, intent(in) :: k, l, r - - real(wp), intent(out), target :: rho - real(wp), intent(out), target :: gamma - real(wp), intent(out), target :: pi_inf - real(wp), intent(out), target :: qv - - real(wp), optional, dimension(2), intent(out) :: Re_K - !! Partial densities and volume fractions - real(wp), optional, intent(out) :: G_K - real(wp), optional, dimension(num_fluids), intent(in) :: G - - real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< - - integer :: i, j !< Generic loop iterator - - ! Computing the density, the specific heat ratio function and the - ! liquid stiffness function, respectively - - do i = 1, num_fluids - alpha_rho_K(i) = q_vf(i)%sf(k, l, r) - alpha_K(i) = q_vf(advxb + i - 1)%sf(k, l, r) - end do - - if (mpp_lim) then - - do i = 1, num_fluids - alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) - alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) - end do - - alpha_K = alpha_K/max(sum(alpha_K), 1e-16_wp) - - end if - - ! Calculating the density, the specific heat ratio function, the - ! liquid stiffness function, and the energy reference function, - ! respectively, from the species analogs - rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp - - do i = 1, num_fluids - rho = rho + alpha_rho_K(i) - gamma = gamma + alpha_K(i)*gammas(i) - pi_inf = pi_inf + alpha_K(i)*pi_infs(i) - qv = qv + alpha_rho_K(i)*qvs(i) - end do -#ifdef MFC_SIMULATION - ! Computing the shear and bulk Reynolds numbers from species analogs - do i = 1, 2 - - Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp - - do j = 1, Re_size(i) - Re_K(i) = alpha_K(Re_idx(i, j))/fluid_pp(Re_idx(i, j))%Re(i) & - + Re_K(i) - end do - - Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) - - end do -#endif - - if (present(G_K)) then - G_K = 0._wp - do i = 1, num_fluids - G_K = G_K + alpha_K(i)*G(i) - end do - G_K = max(0._wp, G_K) - end if - - ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated -#ifdef MFC_POST_PROCESS - rho_sf(k, l, r) = rho - gamma_sf(k, l, r) = gamma - pi_inf_sf(k, l, r) = pi_inf - qv_sf(k, l, r) = qv -#endif - - end subroutine s_convert_species_to_mixture_variables - - pure subroutine s_convert_species_to_mixture_variables_acc(rho_K, & - gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, k, l, r, & - G_K, G) -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_convert_species_to_mixture_variables_acc -#else - !$acc routine seq -#endif - - real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K - - real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< - real(wp), dimension(2), intent(out) :: Re_K - !! Partial densities and volume fractions - - real(wp), optional, intent(out) :: G_K - real(wp), optional, dimension(num_fluids), intent(in) :: G - - integer, intent(in) :: k, l, r - - integer :: i, j !< Generic loop iterators - real(wp) :: alpha_K_sum - -#ifdef MFC_SIMULATION - ! Constraining the partial densities and the volume fractions within - ! their physical bounds to make sure that any mixture variables that - ! are derived from them result within the limits that are set by the - ! fluids physical parameters that make up the mixture - rho_K = 0._wp - gamma_K = 0._wp - pi_inf_K = 0._wp - qv_K = 0._wp - - alpha_K_sum = 0._wp - - if (mpp_lim) then - do i = 1, num_fluids - alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) - alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) - alpha_K_sum = alpha_K_sum + alpha_K(i) - end do - - alpha_K = alpha_K/max(alpha_K_sum, sgm_eps) - - end if - - do i = 1, num_fluids - rho_K = rho_K + alpha_rho_K(i) - gamma_K = gamma_K + alpha_K(i)*gammas(i) - pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) - qv_K = qv_K + alpha_rho_K(i)*qvs(i) - end do - - if (present(G_K)) then - G_K = 0._wp - do i = 1, num_fluids - !TODO: change to use Gs directly here? - !TODO: Make this changes as well for GPUs - G_K = G_K + alpha_K(i)*G(i) - end do - G_K = max(0._wp, G_K) - end if - - if (viscous) then - - do i = 1, 2 - Re_K(i) = dflt_real - - if (Re_size(i) > 0) Re_K(i) = 0._wp - - do j = 1, Re_size(i) - Re_K(i) = alpha_K(Re_idx(i, j))/Res(i, j) & - + Re_K(i) - end do - - Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) - - end do - end if -#endif - - end subroutine s_convert_species_to_mixture_variables_acc - - pure subroutine s_convert_species_to_mixture_variables_bubbles_acc(rho_K, & - gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, k, l, r) -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_convert_species_to_mixture_variables_bubbles_acc -#else - !$acc routine seq -#endif - - real(wp), intent(inout) :: rho_K, gamma_K, pi_inf_K, qv_K - - real(wp), dimension(num_fluids), intent(in) :: alpha_K, alpha_rho_K !< - !! Partial densities and volume fractions - - real(wp), dimension(2), intent(out) :: Re_K - integer, intent(in) :: k, l, r - - integer :: i, j !< Generic loop iterators - -#ifdef MFC_SIMULATION - rho_K = 0._wp - gamma_K = 0._wp - pi_inf_K = 0._wp - qv_K = 0._wp - - if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then - do i = 1, num_fluids - rho_K = rho_K + alpha_rho_K(i) - gamma_K = gamma_K + alpha_K(i)*gammas(i) - pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) - qv_K = qv_K + alpha_rho_K(i)*qvs(i) - end do - else if ((model_eqns == 2) .and. (num_fluids > 2)) then - do i = 1, num_fluids - 1 - rho_K = rho_K + alpha_rho_K(i) - gamma_K = gamma_K + alpha_K(i)*gammas(i) - pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) - qv_K = qv_K + alpha_rho_K(i)*qvs(i) - end do - else - rho_K = alpha_rho_K(1) - gamma_K = gammas(1) - pi_inf_K = pi_infs(1) - qv_K = qvs(1) - end if - - if (viscous) then - if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 - - do i = 1, 2 - Re_K(i) = dflt_real - - if (Re_size(i) > 0) Re_K(i) = 0._wp - - do j = 1, Re_size(i) - Re_K(i) = (1._wp - alpha_K(Re_idx(i, j)))/Res(i, j) & - + Re_K(i) - end do - - Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) - - end do - end if - end if -#endif - - end subroutine s_convert_species_to_mixture_variables_bubbles_acc - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. - impure subroutine s_initialize_variables_conversion_module - - integer :: i, j - -!$acc enter data copyin(is1b, is1e, is2b, is2e, is3b, is3e) - -#ifdef MFC_SIMULATION - @:ALLOCATE(gammas (1:num_fluids)) - @:ALLOCATE(gs_min (1:num_fluids)) - @:ALLOCATE(pi_infs(1:num_fluids)) - @:ALLOCATE(ps_inf(1:num_fluids)) - @:ALLOCATE(cvs (1:num_fluids)) - @:ALLOCATE(qvs (1:num_fluids)) - @:ALLOCATE(qvps (1:num_fluids)) - @:ALLOCATE(Gs (1:num_fluids)) -#else - @:ALLOCATE(gammas (1:num_fluids)) - @:ALLOCATE(gs_min (1:num_fluids)) - @:ALLOCATE(pi_infs(1:num_fluids)) - @:ALLOCATE(ps_inf(1:num_fluids)) - @:ALLOCATE(cvs (1:num_fluids)) - @:ALLOCATE(qvs (1:num_fluids)) - @:ALLOCATE(qvps (1:num_fluids)) - @:ALLOCATE(Gs (1:num_fluids)) -#endif - - do i = 1, num_fluids - gammas(i) = fluid_pp(i)%gamma - gs_min(i) = 1.0_wp/gammas(i) + 1.0_wp - pi_infs(i) = fluid_pp(i)%pi_inf - Gs(i) = fluid_pp(i)%G - ps_inf(i) = pi_infs(i)/(1.0_wp + gammas(i)) - cvs(i) = fluid_pp(i)%cv - qvs(i) = fluid_pp(i)%qv - qvps(i) = fluid_pp(i)%qvp - end do -!$acc update device(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) - -#ifdef MFC_SIMULATION - - if (viscous) then - @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) - do i = 1, 2 - do j = 1, Re_size(i) - Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) - end do - end do - - !$acc update device(Res, Re_idx, Re_size) - end if -#endif - - if (bubbles_euler) then -#ifdef MFC_SIMULATION - @:ALLOCATE(bubrs(1:nb)) -#else - @:ALLOCATE(bubrs(1:nb)) -#endif - - do i = 1, nb - bubrs(i) = bub_idx%rs(i) - end do - !$acc update device(bubrs) - end if - -#ifdef MFC_POST_PROCESS - ! Allocating the density, the specific heat ratio function and the - ! liquid stiffness function, respectively - - ! Simulation is at least 2D - if (n > 0) then - - ! Simulation is 3D - if (p > 0) then - - allocate (rho_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (gamma_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - allocate (qv_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - -buff_size:p + buff_size)) - - ! Simulation is 2D - else - - allocate (rho_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, & - -buff_size:n + buff_size, & - 0:0)) - end if - - ! Simulation is 1D - else - - allocate (rho_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (gamma_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (pi_inf_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - allocate (qv_sf(-buff_size:m + buff_size, & - 0:0, & - 0:0)) - - end if -#endif - - end subroutine s_initialize_variables_conversion_module - - !Initialize mv at the quadrature nodes based on the initialized moments and sigma - pure subroutine s_initialize_mv(qK_cons_vf, mv) - - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - - real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: mv - - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc - - do l = idwint(3)%beg, idwint(3)%end - do k = idwint(2)%beg, idwint(2)%end - do j = idwint(1)%beg, idwint(1)%end - - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - - !$acc loop seq - do i = 1, nb - mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5_wp - - mv(j, k, l, 1, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) - mv(j, k, l, 2, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) - mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) - mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) - end do - - end do - end do - end do - - end subroutine s_initialize_mv - - !Initialize pb at the quadrature nodes using isothermal relations (Preston model) - pure subroutine s_initialize_pb(qK_cons_vf, mv, pb) - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - - real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv - real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: pb - - integer :: i, j, k, l - real(wp) :: mu, sig, nbub_sc - - do l = idwint(3)%beg, idwint(3)%end - do k = idwint(2)%beg, idwint(2)%end - do j = idwint(1)%beg, idwint(1)%end - - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - - !$acc loop seq - do i = 1, nb - mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5_wp - - !PRESTON (ISOTHERMAL) - pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) - pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) - end do - end do - end do - end do - - end subroutine s_initialize_pb - - !> The following procedure handles the conversion between - !! the conservative variables and the primitive variables. - !! @param qK_cons_vf Conservative variables - !! @param qK_prim_vf Primitive variables - !! @param gm_alphaK_vf Gradient magnitude of the volume fraction - !! @param ix Index bounds in first coordinate direction - !! @param iy Index bounds in second coordinate direction - !! @param iz Index bounds in third coordinate direction - subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, & - q_T_sf, & - qK_prim_vf, & - ibounds, & - gm_alphaK_vf) - - type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf - type(scalar_field), intent(inout) :: q_T_sf - type(scalar_field), dimension(sys_size), intent(inout) :: qK_prim_vf - type(int_bounds_info), dimension(1:3), intent(in) :: ibounds - type(scalar_field), & - allocatable, optional, dimension(:), & - intent(in) :: gm_alphaK_vf - - real(wp), dimension(num_fluids) :: alpha_K, alpha_rho_K - real(wp), dimension(2) :: Re_K - real(wp) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K - - #:if MFC_CASE_OPTIMIZATION -#ifndef MFC_SIMULATION - real(wp), dimension(:), allocatable :: nRtmp -#else - real(wp), dimension(nb) :: nRtmp -#endif - #:else - real(wp), dimension(:), allocatable :: nRtmp - #:endif - - real(wp) :: rhoYks(1:num_species) - - real(wp) :: vftmp, nbub_sc - - real(wp) :: G_K - - real(wp) :: pres - - integer :: i, j, k, l !< Generic loop iterators - - real(wp) :: T - real(wp) :: pres_mag - - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: B2 ! Magnetic field magnitude squared - real(wp) :: B(3) ! Magnetic field components - real(wp) :: m2 ! Relativistic momentum magnitude squared - real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum - real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson - real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration - real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration - integer :: iter ! Newton-Raphson iteration counter - - #:if MFC_CASE_OPTIMIZATION -#ifndef MFC_SIMULATION - if (bubbles_euler) then - allocate (nRtmp(nb)) - else - allocate (nRtmp(0)) - end if -#endif - #:else - if (bubbles_euler) then - allocate (nRtmp(nb)) - else - allocate (nRtmp(0)) - end if - #:endif - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, & - !$acc pi_inf_K, qv_K, dyn_pres_K, rhoYks, B) - do l = ibounds(3)%beg, ibounds(3)%end - do k = ibounds(2)%beg, ibounds(2)%end - do j = ibounds(1)%beg, ibounds(1)%end - dyn_pres_K = 0._wp - - !$acc loop seq - do i = 1, num_fluids - alpha_rho_K(i) = qK_cons_vf(i)%sf(j, k, l) - alpha_K(i) = qK_cons_vf(advxb + i - 1)%sf(j, k, l) - end do - - if (model_eqns /= 4) then -#ifdef MFC_SIMULATION - ! If in simulation, use acc mixture subroutines - if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, & - alpha_rho_K, Re_K, j, k, l, G_K, Gs) - else if (bubbles_euler) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, j, k, l) - else - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, j, k, l) - end if -#else - ! If pre-processing, use non acc mixture subroutines - if (elasticity) then - call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & - rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, fluid_pp(:)%G) - else - call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & - rho_K, gamma_K, pi_inf_K, qv_K) - end if -#endif - end if - - if (relativity) then - if (n == 0) then - B(1) = Bx0 - B(2) = qK_cons_vf(B_idx%beg)%sf(j, k, l) - B(3) = qK_cons_vf(B_idx%beg + 1)%sf(j, k, l) - else - B(1) = qK_cons_vf(B_idx%beg)%sf(j, k, l) - B(2) = qK_cons_vf(B_idx%beg + 1)%sf(j, k, l) - B(3) = qK_cons_vf(B_idx%beg + 2)%sf(j, k, l) - end if - B2 = B(1)**2 + B(2)**2 + B(3)**2 - - m2 = 0._wp - !$acc loop seq - do i = momxb, momxe - m2 = m2 + qK_cons_vf(i)%sf(j, k, l)**2 - end do - - S = 0._wp - !$acc loop seq - do i = 1, 3 - S = S + qK_cons_vf(momxb + i - 1)%sf(j, k, l)*B(i) - end do - - E = qK_cons_vf(E_idx)%sf(j, k, l) - - D = 0._wp - !$acc loop seq - do i = 1, contxe - D = D + qK_cons_vf(i)%sf(j, k, l) - end do - - ! Newton-Raphson - W = E + D - !$acc loop seq - do iter = 1, relativity_cons_to_prim_max_iter - Ga = (W + B2)*W/sqrt((W + B2)**2*W**2 - (m2*W**2 + S**2*(2*W + B2))) - pres = (W - D*Ga)/((gamma_K + 1)*Ga**2) ! Thermal pressure from EOS - f = W - pres + (1 - 1/(2*Ga**2))*B2 - S**2/(2*W**2) - E - D - - ! The first equation below corrects a typo in (Mignone & Bodo, 2006) - ! m2*W**2 → 2*m2*W**2, which would cancel with the 2* in other terms - ! This corrected version is not used as the second equation empirically converges faster. - ! First equation is kept for further investigation. - ! dGa_dW = -Ga**3 * ( S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) - dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) - - dp_dW = (Ga*(1 + D*dGa_dW) - 2*W*dGa_dW)/((gamma_K + 1)*Ga**3) - df_dW = 1 - dp_dW + (B2/Ga**3)*dGa_dW + S**2/W**3 - - dW = -f/df_dW - W = W + dW - if (abs(dW) < 1e-12*W) exit - end do - - ! Recalculate pressure using converged W - Ga = (W + B2)*W/sqrt((W + B2)**2*W**2 - (m2*W**2 + S**2*(2*W + B2))) - qK_prim_vf(E_idx)%sf(j, k, l) = (W - D*Ga)/((gamma_K + 1)*Ga**2) - - ! Recover the other primitive variables - !$acc loop seq - do i = 1, 3 - qK_prim_vf(momxb + i - 1)%sf(j, k, l) = (qK_cons_vf(momxb + i - 1)%sf(j, k, l) + (S/W)*B(i))/(W + B2) - end do - qK_prim_vf(1)%sf(j, k, l) = D/Ga ! Hard-coded for single-component for now - - !$acc loop seq - do i = B_idx%beg, B_idx%end - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) - end do - - cycle ! skip all the non-relativistic conversions below - end if - - if (chemistry) then - rho_K = 0._wp - !$acc loop seq - do i = chemxb, chemxe - rho_K = rho_K + max(0._wp, qK_cons_vf(i)%sf(j, k, l)) - end do - - !$acc loop seq - do i = 1, contxe - qK_prim_vf(i)%sf(j, k, l) = rho_K - end do - - !$acc loop seq - do i = chemxb, chemxe - qK_prim_vf(i)%sf(j, k, l) = max(0._wp, qK_cons_vf(i)%sf(j, k, l)/rho_K) - end do - else - !$acc loop seq - do i = 1, contxe - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) - end do - end if - -#ifdef MFC_SIMULATION - rho_K = max(rho_K, sgm_eps) -#endif - - !$acc loop seq - do i = momxb, momxe - if (model_eqns /= 4) then - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & - /rho_K - dyn_pres_K = dyn_pres_K + 5e-1_wp*qK_cons_vf(i)%sf(j, k, l) & - *qK_prim_vf(i)%sf(j, k, l) - else - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & - /qK_cons_vf(1)%sf(j, k, l) - end if - end do - - if (chemistry) then - !$acc loop seq - do i = 1, num_species - rhoYks(i) = qK_cons_vf(chemxb + i - 1)%sf(j, k, l) - end do - - T = q_T_sf%sf(j, k, l) - end if - - if (mhd) then - if (n == 0) then - pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2) - else - pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) - end if - else - pres_mag = 0._wp - end if - - call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), & - qK_cons_vf(alf_idx)%sf(j, k, l), & - dyn_pres_K, pi_inf_K, gamma_K, rho_K, & - qv_K, rhoYks, pres, T, pres_mag=pres_mag) - - qK_prim_vf(E_idx)%sf(j, k, l) = pres - - if (chemistry) then - q_T_sf%sf(j, k, l) = T - end if - - if (bubbles_euler) then - !$acc loop seq - do i = 1, nb - nRtmp(i) = qK_cons_vf(bubrs(i))%sf(j, k, l) - end do - - vftmp = qK_cons_vf(alf_idx)%sf(j, k, l) - - if (qbmm) then - !Get nb (constant across all R0 bins) - nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) - - !Convert cons to prim - !$acc loop seq - do i = bubxb, bubxe - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc - end do - !Need to keep track of nb in the primitive variable list (converted back to true value before output) -#ifdef MFC_SIMULATION - qK_prim_vf(bubxb)%sf(j, k, l) = qK_cons_vf(bubxb)%sf(j, k, l) -#endif - - else - if (adv_n) then - qK_prim_vf(n_idx)%sf(j, k, l) = qK_cons_vf(n_idx)%sf(j, k, l) - nbub_sc = qK_prim_vf(n_idx)%sf(j, k, l) - else - call s_comp_n_from_cons(vftmp, nRtmp, nbub_sc, weight) - end if - - !$acc loop seq - do i = bubxb, bubxe - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc - end do - end if - end if - - if (mhd) then - !$acc loop seq - do i = B_idx%beg, B_idx%end - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) - end do - end if - - if (elasticity) then - !$acc loop seq - do i = strxb, strxe - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K - end do - end if - - if (hypoelasticity) then - !$acc loop seq - do i = strxb, strxe - ! subtracting elastic contribution for pressure calculation - if (G_K > verysmall) then - if (cont_damage) G_K = G_K*max((1._wp - qK_cons_vf(damage_idx)%sf(j, k, l)), 0._wp) - qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & - ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K - ! Double for shear stresses - if (any(i == shear_indices)) then - qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & - ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K - end if - end if - end do - end if - - if (hyperelasticity) then - !$acc loop seq - do i = xibeg, xiend - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K - end do - end if - - !$acc loop seq - do i = advxb, advxe - qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) - end do - - if (surface_tension) then - qK_prim_vf(c_idx)%sf(j, k, l) = qK_cons_vf(c_idx)%sf(j, k, l) - end if - - if (cont_damage) qK_prim_vf(damage_idx)%sf(j, k, l) = qK_cons_vf(damage_idx)%sf(j, k, l) - - end do - end do - end do - !$acc end parallel loop - - end subroutine s_convert_conservative_to_primitive_variables - - !> The following procedure handles the conversion between - !! the primitive variables and the conservative variables. - !! @param qK_prim_vf Primitive variables - !! @param qK_cons_vf Conservative variables - !! @param gm_alphaK_vf Gradient magnitude of the volume fractions - !! @param ix Index bounds in the first coordinate direction - !! @param iy Index bounds in the second coordinate direction - !! @param iz Index bounds in the third coordinate direction - impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, & - q_cons_vf) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf - - ! Density, specific heat ratio function, liquid stiffness function - ! and dynamic pressure, as defined in the incompressible flow sense, - ! respectively - real(wp) :: rho - real(wp) :: gamma - real(wp) :: pi_inf - real(wp) :: qv - real(wp) :: dyn_pres - real(wp) :: nbub, R3tmp - real(wp), dimension(nb) :: Rtmp - real(wp) :: G - real(wp), dimension(2) :: Re_K - - integer :: i, j, k, l !< Generic loop iterators - - real(wp), dimension(num_species) :: Ys - real(wp) :: e_mix, mix_mol_weight, T - real(wp) :: pres_mag - - real(wp) :: Ga ! Lorentz factor (gamma in relativity) - real(wp) :: h ! relativistic enthalpy - real(wp) :: v2 ! Square of the velocity magnitude - real(wp) :: B2 ! Square of the magnetic field magnitude - real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors - real(wp) :: B(3) ! Magnetic field components - - pres_mag = 0._wp - - G = 0._wp - -#ifndef MFC_SIMULATION - ! Converting the primitive variables to the conservative variables - do l = 0, p - do k = 0, n - do j = 0, m - - ! Obtaining the density, specific heat ratio function - ! and the liquid stiffness function, respectively - call s_convert_to_mixture_variables(q_prim_vf, j, k, l, & - rho, gamma, pi_inf, qv, Re_K, G, fluid_pp(:)%G) - - ! Transferring the advection equation(s) variable(s) - do i = adv_idx%beg, adv_idx%end - q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) - end do - - if (relativity) then - - if (n == 0) then - B(1) = Bx0 - B(2) = q_prim_vf(B_idx%beg)%sf(j, k, l) - B(3) = q_prim_vf(B_idx%beg + 1)%sf(j, k, l) - else - B(1) = q_prim_vf(B_idx%beg)%sf(j, k, l) - B(2) = q_prim_vf(B_idx%beg + 1)%sf(j, k, l) - B(3) = q_prim_vf(B_idx%beg + 2)%sf(j, k, l) - end if - - v2 = 0._wp - do i = momxb, momxe - v2 = v2 + q_prim_vf(i)%sf(j, k, l)**2 - end do - if (v2 >= 1._wp) call s_mpi_abort('Error: v squared > 1 in s_convert_primitive_to_conservative_variables') - - Ga = 1._wp/sqrt(1._wp - v2) - - h = 1._wp + (gamma + 1)*q_prim_vf(E_idx)%sf(j, k, l)/rho ! Assume perfect gas for now - - B2 = 0._wp - do i = B_idx%beg, B_idx%end - B2 = B2 + q_prim_vf(i)%sf(j, k, l)**2 - end do - if (n == 0) B2 = B2 + Bx0**2 - - vdotB = 0._wp - do i = 1, 3 - vdotB = vdotB + q_prim_vf(momxb + i - 1)%sf(j, k, l)*B(i) - end do - - do i = 1, contxe - q_cons_vf(i)%sf(j, k, l) = Ga*q_prim_vf(i)%sf(j, k, l) - end do - - do i = momxb, momxe - q_cons_vf(i)%sf(j, k, l) = (rho*h*Ga**2 + B2)*q_prim_vf(i)%sf(j, k, l) & - - vdotB*B(i - momxb + 1) - end do - - q_cons_vf(E_idx)%sf(j, k, l) = rho*h*Ga**2 - q_prim_vf(E_idx)%sf(j, k, l) & - + 0.5_wp*(B2 + v2*B2 - vdotB**2) - ! Remove rest energy - do i = 1, contxe - q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) - q_cons_vf(i)%sf(j, k, l) - end do - - do i = B_idx%beg, B_idx%end - q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) - end do - - cycle ! skip all the non-relativistic conversions below - - end if - - ! Transferring the continuity equation(s) variable(s) - do i = 1, contxe - q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) - end do - - ! Zeroing out the dynamic pressure since it is computed - ! iteratively by cycling through the velocity equations - dyn_pres = 0._wp - - ! Computing momenta and dynamic pressure from velocity - do i = momxb, momxe - q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) - dyn_pres = dyn_pres + q_cons_vf(i)%sf(j, k, l)* & - q_prim_vf(i)%sf(j, k, l)/2._wp - end do - - if (chemistry) then - do i = chemxb, chemxe - Ys(i - chemxb + 1) = q_prim_vf(i)%sf(j, k, l) - q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) - end do - - call get_mixture_molecular_weight(Ys, mix_mol_weight) - T = q_prim_vf(E_idx)%sf(j, k, l)*mix_mol_weight/(gas_constant*rho) - call get_mixture_energy_mass(T, Ys, e_mix) - - q_cons_vf(E_idx)%sf(j, k, l) = & - dyn_pres + rho*e_mix - else - ! Computing the energy from the pressure - if (mhd) then - if (n == 0) then - pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2) - else - pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) - end if - q_cons_vf(E_idx)%sf(j, k, l) = & - gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag & - + pi_inf + qv - elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then - ! E = Gamma*P + \rho u u /2 + \pi_inf + (\alpha\rho qv) - q_cons_vf(E_idx)%sf(j, k, l) = & - gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pi_inf & - + qv - else if ((model_eqns /= 4) .and. (bubbles_euler)) then - ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) - q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + & - (1._wp - q_prim_vf(alf_idx)%sf(j, k, l))* & - (gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) - else - !Tait EOS, no conserved energy variable - q_cons_vf(E_idx)%sf(j, k, l) = 0._wp - end if - end if - - ! Computing the internal energies from the pressure and continuities - if (model_eqns == 3) then - do i = 1, num_fluids - ! internal energy calculation for each of the fluids - q_cons_vf(i + internalEnergies_idx%beg - 1)%sf(j, k, l) = & - q_cons_vf(i + adv_idx%beg - 1)%sf(j, k, l)* & - (fluid_pp(i)%gamma*q_prim_vf(E_idx)%sf(j, k, l) + & - fluid_pp(i)%pi_inf) + & - q_cons_vf(i + cont_idx%beg - 1)%sf(j, k, l)*fluid_pp(i)%qv - end do - end if - - if (bubbles_euler) then - ! From prim: Compute nbub = (3/4pi) * \alpha / \bar{R^3} - do i = 1, nb - Rtmp(i) = q_prim_vf(bub_idx%rs(i))%sf(j, k, l) - end do - - if (.not. qbmm) then - if (adv_n) then - q_cons_vf(n_idx)%sf(j, k, l) = q_prim_vf(n_idx)%sf(j, k, l) - nbub = q_prim_vf(n_idx)%sf(j, k, l) - else - call s_comp_n_from_prim(q_prim_vf(alf_idx)%sf(j, k, l), Rtmp, nbub, weight) - end if - else - !Initialize R3 averaging over R0 and R directions - R3tmp = 0._wp - do i = 1, nb - R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) + sigR)**3._wp - R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) - sigR)**3._wp - end do - !Initialize nb - nbub = 3._wp*q_prim_vf(alf_idx)%sf(j, k, l)/(4._wp*pi*R3tmp) - end if - - if (j == 0 .and. k == 0 .and. l == 0) print *, 'In convert, nbub:', nbub - - do i = bub_idx%beg, bub_idx%end - q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l)*nbub - end do - end if - - if (mhd) then - do i = B_idx%beg, B_idx%end - q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) - end do - end if - - if (elasticity) then - ! adding the elastic contribution - ! Multiply \tau to \rho \tau - do i = strxb, strxe - q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) - end do - end if - - if (hypoelasticity) then - do i = strxb, strxe - ! adding elastic contribution - if (G > verysmall) then - if (cont_damage) G = G*max((1._wp - q_prim_vf(damage_idx)%sf(j, k, l)), 0._wp) - - q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & - (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) - ! Double for shear stresses - if (any(i == shear_indices)) then - q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & - (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) - end if - end if - end do - end if - - ! using \rho xi as the conservative formulation stated in Kamrin et al. JFM 2022 - if (hyperelasticity) then - ! Multiply \xi to \rho \xi - do i = xibeg, xiend - q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) - end do - end if - - if (surface_tension) then - q_cons_vf(c_idx)%sf(j, k, l) = q_prim_vf(c_idx)%sf(j, k, l) - end if - - if (cont_damage) q_cons_vf(damage_idx)%sf(j, k, l) = q_prim_vf(damage_idx)%sf(j, k, l) - - end do - end do - end do -#else - if (proc_rank == 0) then - call s_mpi_abort('Conversion from primitive to '// & - 'conservative variables not '// & - 'implemented. Exiting.') - end if -#endif - end subroutine s_convert_primitive_to_conservative_variables - - !> The following subroutine handles the conversion between - !! the primitive variables and the Eulerian flux variables. - !! @param qK_prim_vf Primitive variables - !! @param FK_vf Flux variables - !! @param FK_src_vf Flux source variables - !! @param ix Index bounds in the first coordinate direction - !! @param iy Index bounds in the second coordinate direction - !! @param iz Index bounds in the third coordinate direction - subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, & - FK_vf, & - FK_src_vf, & - is1, is2, is3, s2b, s3b) - - integer, intent(in) :: s2b, s3b - real(wp), dimension(0:, s2b:, s3b:, 1:), intent(in) :: qK_prim_vf - real(wp), dimension(0:, s2b:, s3b:, 1:), intent(inout) :: FK_vf - real(wp), dimension(0:, s2b:, s3b:, advxb:), intent(inout) :: FK_src_vf - - type(int_bounds_info), intent(in) :: is1, is2, is3 - - ! Partial densities, density, velocity, pressure, energy, advection - ! variables, the specific heat ratio and liquid stiffness functions, - ! the shear and volume Reynolds numbers and the Weber numbers - real(wp), dimension(num_fluids) :: alpha_rho_K - real(wp), dimension(num_fluids) :: alpha_K - real(wp) :: rho_K - real(wp), dimension(num_vels) :: vel_K - real(wp) :: vel_K_sum - real(wp) :: pres_K - real(wp) :: E_K - real(wp) :: gamma_K - real(wp) :: pi_inf_K - real(wp) :: qv_K - real(wp), dimension(2) :: Re_K - real(wp) :: G_K - real(wp), dimension(num_species) :: Y_K - real(wp) :: T_K, mix_mol_weight, R_gas - - integer :: i, j, k, l !< Generic loop iterators - - is1b = is1%beg; is1e = is1%end - is2b = is2%beg; is2e = is2%end - is3b = is3%beg; is3e = is3%end - - !$acc update device(is1b, is2b, is3b, is1e, is2e, is3e) - - ! Computing the flux variables from the primitive variables, without - ! accounting for the contribution of either viscosity or capillarity -#ifdef MFC_SIMULATION - !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_K, vel_K, alpha_K, Re_K, Y_K) - do l = is3b, is3e - do k = is2b, is2e - do j = is1b, is1e - - !$acc loop seq - do i = 1, contxe - alpha_rho_K(i) = qK_prim_vf(j, k, l, i) - end do - - !$acc loop seq - do i = advxb, advxe - alpha_K(i - E_idx) = qK_prim_vf(j, k, l, i) - end do - !$acc loop seq - do i = 1, num_vels - vel_K(i) = qK_prim_vf(j, k, l, contxe + i) - end do - - vel_K_sum = 0._wp - !$acc loop seq - do i = 1, num_vels - vel_K_sum = vel_K_sum + vel_K(i)**2._wp - end do - - pres_K = qK_prim_vf(j, k, l, E_idx) - if (elasticity) then - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, & - j, k, l, G_K, Gs) - else if (bubbles_euler) then - call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, & - pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, j, k, l) - else - call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & - alpha_K, alpha_rho_K, Re_K, j, k, l) - end if - - ! Computing the energy from the pressure - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Y_K(i - chemxb + 1) = qK_prim_vf(j, k, l, i) - end do - !Computing the energy from the internal energy of the mixture - call get_mixture_molecular_weight(Y_k, mix_mol_weight) - R_gas = gas_constant/mix_mol_weight - T_K = pres_K/rho_K/R_gas - call get_mixture_energy_mass(T_K, Y_K, E_K) - E_K = rho_K*E_K + 5e-1_wp*rho_K*vel_K_sum - else - ! Computing the energy from the pressure - E_K = gamma_K*pres_K + pi_inf_K & - + 5e-1_wp*rho_K*vel_K_sum + qv_K - end if - - ! mass flux, this should be \alpha_i \rho_i u_i - !$acc loop seq - do i = 1, contxe - FK_vf(j, k, l, i) = alpha_rho_K(i)*vel_K(dir_idx(1)) - end do - - !$acc loop seq - do i = 1, num_vels - FK_vf(j, k, l, contxe + dir_idx(i)) = & - rho_K*vel_K(dir_idx(1)) & - *vel_K(dir_idx(i)) & - + pres_K*dir_flg(dir_idx(i)) - end do - - ! energy flux, u(E+p) - FK_vf(j, k, l, E_idx) = vel_K(dir_idx(1))*(E_K + pres_K) - - ! Species advection Flux, \rho*u*Y - if (chemistry) then - !$acc loop seq - do i = 1, num_species - FK_vf(j, k, l, i - 1 + chemxb) = vel_K(dir_idx(1))*(rho_K*Y_K(i)) - end do - end if - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc loop seq - do i = advxb, advxe - FK_vf(j, k, l, i) = 0._wp - FK_src_vf(j, k, l, i) = alpha_K(i - E_idx) - end do - - else - ! Could be bubbles_euler! - !$acc loop seq - do i = advxb, advxe - FK_vf(j, k, l, i) = vel_K(dir_idx(1))*alpha_K(i - E_idx) - end do - - !$acc loop seq - do i = advxb, advxe - FK_src_vf(j, k, l, i) = vel_K(dir_idx(1)) - end do - - end if - - end do - end do - end do -#endif - end subroutine s_convert_primitive_to_flux_variables - - impure subroutine s_finalize_variables_conversion_module() - - ! Deallocating the density, the specific heat ratio function and the - ! liquid stiffness function -#ifdef MFC_POST_PROCESS - deallocate (rho_sf, gamma_sf, pi_inf_sf, qv_sf) -#endif - -#ifdef MFC_SIMULATION - @:DEALLOCATE(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) - if (bubbles_euler) then - @:DEALLOCATE(bubrs) - end if -#else - @:DEALLOCATE(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) - if (bubbles_euler) then - @:DEALLOCATE(bubrs) - end if -#endif - - end subroutine s_finalize_variables_conversion_module - -#ifndef MFC_PRE_PROCESS - pure subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c) -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_compute_speed_of_sound -#else - !$acc routine seq -#endif - - real(wp), intent(in) :: pres - real(wp), intent(in) :: rho, gamma, pi_inf - real(wp), intent(in) :: H - real(wp), dimension(num_fluids), intent(in) :: adv - real(wp), intent(in) :: vel_sum - real(wp), intent(in) :: c_c - real(wp), intent(out) :: c - - real(wp) :: blkmod1, blkmod2 - real(wp) :: Tolerance - - integer :: q - - if (chemistry) then - if (avg_state == 1 .and. abs(c_c) > Tolerance) then - c = sqrt(c_c - (gamma - 1.0_wp)*(vel_sum - H)) - else - c = sqrt((1.0_wp + 1.0_wp/gamma)*pres/rho) - end if - elseif (relativity) then - ! Only supports perfect gas for now - c = sqrt((1._wp + 1._wp/gamma)*pres/rho/H) - else - if (alt_soundspeed) then - blkmod1 = ((gammas(1) + 1._wp)*pres + & - pi_infs(1))/gammas(1) - blkmod2 = ((gammas(2) + 1._wp)*pres + & - pi_infs(2))/gammas(2) - c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) - elseif (model_eqns == 3) then - c = 0._wp - !$acc loop seq - do q = 1, num_fluids - c = c + adv(q)*(1._wp/gammas(q) + 1._wp)* & - (pres + pi_infs(q)/(gammas(q) + 1._wp)) - end do - c = c/rho - elseif (((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles_euler))) then - ! Sound speed for bubble mmixture to order O(\alpha) - - if (mpp_lim .and. (num_fluids > 1)) then - c = (1._wp/gamma + 1._wp)* & - (pres + pi_inf/(gamma + 1._wp))/rho - else - c = & - (1._wp/gamma + 1._wp)* & - (pres + pi_inf/(gamma + 1._wp))/ & - (rho*(1._wp - adv(num_fluids))) - end if - else - c = ((H - 5e-1*vel_sum)/gamma) - end if - - if (mixture_err .and. c < 0._wp) then - c = 100._wp*sgm_eps - else - c = sqrt(c) - end if - end if - end subroutine s_compute_speed_of_sound -#endif - -#ifndef MFC_PRE_PROCESS - pure subroutine s_compute_fast_magnetosonic_speed(rho, c, B, norm, c_fast, h) -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_compute_fast_magnetosonic_speed -#else - !$acc routine seq -#endif - - real(wp), intent(in) :: B(3), rho, c - real(wp), intent(in) :: h ! only used for relativity - real(wp), intent(out) :: c_fast - integer, intent(in) :: norm - - real(wp) :: B2, term, disc - - B2 = sum(B**2) - - if (.not. relativity) then - term = c**2 + B2/rho - disc = term**2 - 4*c**2*(B(norm)**2/rho) - else - ! Note: this is approximation for the non-relatisitic limit; accurate solution requires solving a quartic equation - term = (c**2*(B(norm)**2 + rho*h) + B2)/(rho*h + B2) - disc = term**2 - 4*c**2*B(norm)**2/(rho*h + B2) - end if - -#ifdef DEBUG - if (disc < 0._wp) then - print *, 'rho, c, Bx, By, Bz, h, term, disc:', rho, c, B(1), B(2), B(3), h, term, disc - call s_mpi_abort('Error: negative discriminant in s_compute_fast_magnetosonic_speed') - end if -#endif - - c_fast = sqrt(0.5_wp*(term + sqrt(disc))) - - end subroutine s_compute_fast_magnetosonic_speed -#endif - -#ifndef MFC_PRE_PROCESS - subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, idx, idx_tau) - - ! Computes the wave speeds for the Riemann solver -#ifdef _CRAYFTN - !DIR$ INLINEALWAYS s_compute_wave_speed -#else - !$acc routine seq -#endif - - ! Input parameters - integer, intent(in) :: wave_speeds - integer, intent(in) :: idx, idx_tau - real(wp), intent(in) :: rho_L, rho_R - real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R - real(wp), intent(in) :: pres_L, pres_R, c_L, c_R - real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R - real(wp), intent(in) :: rho_avg, c_avg - real(wp), intent(in) :: c_fast_L, c_fast_R - real(wp), intent(in) :: G_L, G_R - - ! Local variables - real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R - - ! Output parameters - real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P - - if (wave_speeds == 1) then - if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) - s_S = (pres_R - tau_e_R(idx_tau) - pres_L + & - tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & - rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & - rho_R*(s_R - vel_R(idx))) - else if (mhd) then - s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) - s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) - s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) - else if (hypoelasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L)) - s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) - else if (hyperelasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) - s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) - else - s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) - s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) - end if - else if (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) - pres_SR = pres_SL - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - s_L = vel_L(idx) - c_L*Ms_L - s_R = vel_R(idx) + c_R*Ms_R - s_S = 5e-1_wp*((vel_L(idx) + vel_R(idx)) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - ! ! follows Einfeldt et al. - ! s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L) - s_P = max(0._wp, s_R) - -#ifdef DEBUG - ! Check for potential issues in wave speed calculation - if (s_R <= s_L) then - print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' - print *, 'Left wave speed >= Right wave speed:', s_L, s_R - print *, 'Input velocities :', vel_L(idx), vel_R(idx) - print *, 'Sound speeds:', c_L, c_R - print *, 'Densities:', rho_L, rho_R - print *, 'Pressures:', pres_L, pres_R - print *, 'Wave speeds method:', wave_speeds - if (elasticity .or. hypoelasticity .or. hyperelasticity) then - print *, 'Shear moduli:', G_L, G_R - end if - call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') - end if -#endif - end subroutine s_compute_wave_speed -#endif - -end module m_variables_conversion +!> +!! @file m_variables_conversion.f90 +!! @brief Contains module m_variables_conversion + +#:include 'macros.fpp' +#:include 'case.fpp' + +!> @brief This module consists of subroutines used in the conversion of the +!! conservative variables into the primitive ones and vice versa. In +!! addition, the module also contains the subroutines used to obtain +!! the mixture variables and the subroutines used to compute pressure. +module m_variables_conversion + + use m_derived_types !< Definitions of the derived types + + use m_global_parameters !< Definitions of the global parameters + + use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_helper_basic !< Functions to compare floating point numbers + + use m_helper + + use m_thermochem, only: & + num_species, get_temperature, get_pressure, gas_constant, & + get_mixture_molecular_weight, get_mixture_energy_mass + + implicit none + + private; + public :: s_initialize_variables_conversion_module, & + s_initialize_pb, & + s_initialize_mv, & + s_convert_to_mixture_variables, & + s_convert_mixture_to_mixture_variables, & + s_convert_species_to_mixture_variables_bubbles, & + s_convert_species_to_mixture_variables_bubbles_acc, & + s_convert_species_to_mixture_variables, & + s_convert_species_to_mixture_variables_acc, & + s_convert_conservative_to_primitive_variables, & + s_convert_primitive_to_conservative_variables, & + s_convert_primitive_to_flux_variables, & + s_compute_pressure, & +#ifndef MFC_PRE_PROCESS + s_compute_speed_of_sound, & + s_compute_fast_magnetosonic_speed, & + s_compute_wave_speed, & +#endif + s_finalize_variables_conversion_module + + !! In simulation, gammas, pi_infs, and qvs are already declared in m_global_variables +#ifndef MFC_SIMULATION + real(wp), allocatable, public, dimension(:) :: gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps + !$acc declare create(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps) +#endif + + real(wp), allocatable, dimension(:) :: Gs + integer, allocatable, dimension(:) :: bubrs + real(wp), allocatable, dimension(:, :) :: Res + !$acc declare create(bubrs, Gs, Res) + + integer :: is1b, is2b, is3b, is1e, is2e, is3e + !$acc declare create(is1b, is2b, is3b, is1e, is2e, is3e) + + real(wp), allocatable, dimension(:, :, :), public :: rho_sf !< Scalar density function + real(wp), allocatable, dimension(:, :, :), public :: gamma_sf !< Scalar sp. heat ratio function + real(wp), allocatable, dimension(:, :, :), public :: pi_inf_sf !< Scalar liquid stiffness function + real(wp), allocatable, dimension(:, :, :), public :: qv_sf !< Scalar liquid energy reference function + +contains + + !> Dispatch to the s_convert_mixture_to_mixture_variables + !! and s_convert_species_to_mixture_variables subroutines. + !! Replaces a procedure pointer. + !! @param q_vf Conservative or primitive variables + !! @param i First-coordinate cell index + !! @param j First-coordinate cell index + !! @param k First-coordinate cell index + !! @param rho Density + !! @param gamma Specific heat ratio function + !! @param pi_inf Liquid stiffness function + !! @param qv Fluid reference energy + subroutine s_convert_to_mixture_variables(q_vf, i, j, k, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + integer, intent(in) :: i, j, k + real(wp), intent(out), target :: rho, gamma, pi_inf, qv + real(wp), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G + + if (model_eqns == 1) then ! Gamma/pi_inf model + call s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + + else if (bubbles_euler) then + call s_convert_species_to_mixture_variables_bubbles(q_vf, i, j, k, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + else + ! Volume fraction model + call s_convert_species_to_mixture_variables(q_vf, i, j, k, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + end if + + end subroutine s_convert_to_mixture_variables + + !> This procedure conditionally calculates the appropriate pressure + !! @param energy Energy + !! @param alf Void Fraction + !! @param dyn_p Dynamic Pressure + !! @param pi_inf Liquid Stiffness + !! @param gamma Specific Heat Ratio + !! @param rho Density + !! @param qv fluid reference energy + !! @param pres Pressure to calculate + !! @param stress Shear Stress + !! @param mom Momentum + subroutine s_compute_pressure(energy, alf, dyn_p, pi_inf, gamma, rho, qv, rhoYks, pres, T, stress, mom, G, pres_mag) + +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_pressure +#else + !$acc routine seq +#endif + + real(wp), intent(in) :: energy, alf + real(wp), intent(in) :: dyn_p + real(wp), intent(in) :: pi_inf, gamma, rho, qv + real(wp), intent(out) :: pres + real(wp), intent(inout) :: T + real(wp), intent(in), optional :: stress, mom, G, pres_mag + + ! Chemistry + real(wp), dimension(1:num_species), intent(in) :: rhoYks + real(wp) :: E_e + real(wp) :: e_Per_Kg, Pdyn_Per_Kg + real(wp) :: T_guess + real(wp), dimension(1:num_species) :: Y_rs + + integer :: s !< Generic loop iterator + + #:if not chemistry + ! Depending on model_eqns and bubbles_euler, the appropriate procedure + ! for computing pressure is targeted by the procedure pointer + + if (mhd) then + pres = (energy - dyn_p - pi_inf - qv - pres_mag)/gamma + elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then + pres = (energy - dyn_p - pi_inf - qv)/gamma + else if ((model_eqns /= 4) .and. bubbles_euler) then + pres = ((energy - dyn_p)/(1._wp - alf) - pi_inf - qv)/gamma + else + pres = (pref + pi_inf)* & + (energy/ & + (rhoref*(1 - alf)) & + )**(1/gamma + 1) - pi_inf + end if + + if (hypoelasticity .and. present(G)) then + ! calculate elastic contribution to Energy + E_e = 0._wp + do s = stress_idx%beg, stress_idx%end + if (G > 0) then + E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) + ! Double for shear stresses + if (any(s == shear_indices)) then + E_e = E_e + ((stress/rho)**2._wp)/(4._wp*G) + end if + end if + end do + + pres = ( & + energy - & + 0.5_wp*(mom**2._wp)/rho - & + pi_inf - qv - E_e & + )/gamma + + end if + + #:else + + Y_rs(:) = rhoYks(:)/rho + e_Per_Kg = energy/rho + Pdyn_Per_Kg = dyn_p/rho + + T_guess = T + + call get_temperature(e_Per_Kg - Pdyn_Per_Kg, T_guess, Y_rs, .true., T) + call get_pressure(rho, T, Y_rs, pres) + + #:endif + + end subroutine s_compute_pressure + + !> This subroutine is designed for the gamma/pi_inf model + !! and provided a set of either conservative or primitive + !! variables, transfers the density, specific heat ratio + !! function and the liquid stiffness function from q_vf to + !! rho, gamma and pi_inf. + !! @param q_vf conservative or primitive variables + !! @param i cell index to transfer mixture variables + !! @param j cell index to transfer mixture variables + !! @param k cell index to transfer mixture variables + !! @param rho density + !! @param gamma specific heat ratio function + !! @param pi_inf liquid stiffness + !! @param qv fluid reference energy + subroutine s_convert_mixture_to_mixture_variables(q_vf, i, j, k, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + integer, intent(in) :: i, j, k + + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv + + real(wp), optional, dimension(2), intent(out) :: Re_K + + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G + + ! Transferring the density, the specific heat ratio function and the + ! liquid stiffness function, respectively + rho = q_vf(1)%sf(i, j, k) + gamma = q_vf(gamma_idx)%sf(i, j, k) + pi_inf = q_vf(pi_inf_idx)%sf(i, j, k) + qv = 0._wp ! keep this value nill for now. For future adjustment + + ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated +#ifdef MFC_POST_PROCESS + rho_sf(i, j, k) = rho + gamma_sf(i, j, k) = gamma + pi_inf_sf(i, j, k) = pi_inf + qv_sf(i, j, k) = qv +#endif + + end subroutine s_convert_mixture_to_mixture_variables + + !> This procedure is used alongside with the gamma/pi_inf + !! model to transfer the density, the specific heat ratio + !! function and liquid stiffness function from the vector + !! of conservative or primitive variables to their scalar + !! counterparts. Specifically designed for when subgrid bubbles_euler + !! must be included. + !! @param q_vf primitive variables + !! @param j Cell index + !! @param k Cell index + !! @param l Cell index + !! @param rho density + !! @param gamma specific heat ratio + !! @param pi_inf liquid stiffness + !! @param qv fluid reference energy + subroutine s_convert_species_to_mixture_variables_bubbles(q_vf, j, k, l, & + rho, gamma, pi_inf, qv, Re_K, G_K, G) + + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + + integer, intent(in) :: j, k, l + + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv + + real(wp), optional, dimension(2), intent(out) :: Re_K + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G + + integer :: i, q + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K + + ! Constraining the partial densities and the volume fractions within + ! their physical bounds to make sure that any mixture variables that + ! are derived from them result within the limits that are set by the + ! fluids physical parameters that make up the mixture + do i = 1, num_fluids + alpha_rho_K(i) = q_vf(i)%sf(j, k, l) + alpha_K(i) = q_vf(advxb + i - 1)%sf(j, k, l) + end do + + if (mpp_lim) then + + do i = 1, num_fluids + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) + end do + + alpha_K = alpha_K/max(sum(alpha_K), 1e-16_wp) + + end if + + ! Performing the transfer of the density, the specific heat ratio + ! function as well as the liquid stiffness function, respectively + + if (model_eqns == 4) then + rho = q_vf(1)%sf(j, k, l) + gamma = fluid_pp(1)%gamma !qK_vf(gamma_idx)%sf(i,j,k) + pi_inf = fluid_pp(1)%pi_inf !qK_vf(pi_inf_idx)%sf(i,j,k) + qv = fluid_pp(1)%qv + else if ((model_eqns == 2) .and. bubbles_euler) then + rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp + + if (mpp_lim .and. (num_fluids > 2)) then + do i = 1, num_fluids + rho = rho + q_vf(i)%sf(j, k, l) + gamma = gamma + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%gamma + pi_inf = pi_inf + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%pi_inf + qv = qv + q_vf(i)%sf(j, k, l)*fluid_pp(i)%qv + end do + else if (num_fluids == 2) then + rho = q_vf(1)%sf(j, k, l) + gamma = fluid_pp(1)%gamma + pi_inf = fluid_pp(1)%pi_inf + qv = fluid_pp(1)%qv + else if (num_fluids > 2) then + !TODO: This may need fixing for hypo + bubbles_euler + do i = 1, num_fluids - 1 !leave out bubble part of mixture + rho = rho + q_vf(i)%sf(j, k, l) + gamma = gamma + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%gamma + pi_inf = pi_inf + q_vf(i + E_idx)%sf(j, k, l)*fluid_pp(i)%pi_inf + qv = qv + q_vf(i)%sf(j, k, l)*fluid_pp(i)%qv + end do + ! rho = qK_vf(1)%sf(j,k,l) + ! gamma_K = fluid_pp(1)%gamma + ! pi_inf_K = fluid_pp(1)%pi_inf + else + rho = q_vf(1)%sf(j, k, l) + gamma = fluid_pp(1)%gamma + pi_inf = fluid_pp(1)%pi_inf + qv = fluid_pp(1)%qv + end if + end if + +#ifdef MFC_SIMULATION + ! Computing the shear and bulk Reynolds numbers from species analogs + if (viscous) then + if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 + do i = 1, 2 + + Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp + + do q = 1, Re_size(i) + Re_K(i) = (1 - alpha_K(Re_idx(i, q)))/fluid_pp(Re_idx(i, q))%Re(i) & + + Re_K(i) + end do + + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) + + end do + end if + end if +#endif + + ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated +#ifdef MFC_POST_PROCESS + rho_sf(j, k, l) = rho + gamma_sf(j, k, l) = gamma + pi_inf_sf(j, k, l) = pi_inf + qv_sf(j, k, l) = qv +#endif + + end subroutine s_convert_species_to_mixture_variables_bubbles + + !> This subroutine is designed for the volume fraction model + !! and provided a set of either conservative or primitive + !! variables, computes the density, the specific heat ratio + !! function and the liquid stiffness function from q_vf and + !! stores the results into rho, gamma and pi_inf. + !! @param q_vf primitive variables + !! @param k Cell index + !! @param l Cell index + !! @param r Cell index + !! @param rho density + !! @param gamma specific heat ratio + !! @param pi_inf liquid stiffness + !! @param qv fluid reference energy + subroutine s_convert_species_to_mixture_variables(q_vf, k, l, r, rho, & + gamma, pi_inf, qv, Re_K, G_K, G) + + type(scalar_field), dimension(sys_size), intent(in) :: q_vf + + integer, intent(in) :: k, l, r + + real(wp), intent(out), target :: rho + real(wp), intent(out), target :: gamma + real(wp), intent(out), target :: pi_inf + real(wp), intent(out), target :: qv + + real(wp), optional, dimension(2), intent(out) :: Re_K + !! Partial densities and volume fractions + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G + + real(wp), dimension(num_fluids) :: alpha_rho_K, alpha_K !< + + integer :: i, j !< Generic loop iterator + + ! Computing the density, the specific heat ratio function and the + ! liquid stiffness function, respectively + + do i = 1, num_fluids + alpha_rho_K(i) = q_vf(i)%sf(k, l, r) + alpha_K(i) = q_vf(advxb + i - 1)%sf(k, l, r) + end do + + if (mpp_lim) then + + do i = 1, num_fluids + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) + end do + + alpha_K = alpha_K/max(sum(alpha_K), 1e-16_wp) + + end if + + ! Calculating the density, the specific heat ratio function, the + ! liquid stiffness function, and the energy reference function, + ! respectively, from the species analogs + rho = 0._wp; gamma = 0._wp; pi_inf = 0._wp; qv = 0._wp + + do i = 1, num_fluids + rho = rho + alpha_rho_K(i) + gamma = gamma + alpha_K(i)*gammas(i) + pi_inf = pi_inf + alpha_K(i)*pi_infs(i) + qv = qv + alpha_rho_K(i)*qvs(i) + end do +#ifdef MFC_SIMULATION + ! Computing the shear and bulk Reynolds numbers from species analogs + do i = 1, 2 + + Re_K(i) = dflt_real; if (Re_size(i) > 0) Re_K(i) = 0._wp + + do j = 1, Re_size(i) + Re_K(i) = alpha_K(Re_idx(i, j))/fluid_pp(Re_idx(i, j))%Re(i) & + + Re_K(i) + end do + + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) + + end do +#endif + + if (present(G_K)) then + G_K = 0._wp + do i = 1, num_fluids + G_K = G_K + alpha_K(i)*G(i) + end do + G_K = max(0._wp, G_K) + end if + + ! Post process requires rho_sf/gamma_sf/pi_inf_sf/qv_sf to also be updated +#ifdef MFC_POST_PROCESS + rho_sf(k, l, r) = rho + gamma_sf(k, l, r) = gamma + pi_inf_sf(k, l, r) = pi_inf + qv_sf(k, l, r) = qv +#endif + + end subroutine s_convert_species_to_mixture_variables + + pure subroutine s_convert_species_to_mixture_variables_acc(rho_K, & + gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, k, l, r, & + G_K, G) +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_convert_species_to_mixture_variables_acc +#else + !$acc routine seq +#endif + + real(wp), intent(out) :: rho_K, gamma_K, pi_inf_K, qv_K + + real(wp), dimension(num_fluids), intent(inout) :: alpha_rho_K, alpha_K !< + real(wp), dimension(2), intent(out) :: Re_K + !! Partial densities and volume fractions + + real(wp), optional, intent(out) :: G_K + real(wp), optional, dimension(num_fluids), intent(in) :: G + + integer, intent(in) :: k, l, r + + integer :: i, j !< Generic loop iterators + real(wp) :: alpha_K_sum + +#ifdef MFC_SIMULATION + ! Constraining the partial densities and the volume fractions within + ! their physical bounds to make sure that any mixture variables that + ! are derived from them result within the limits that are set by the + ! fluids physical parameters that make up the mixture + rho_K = 0._wp + gamma_K = 0._wp + pi_inf_K = 0._wp + qv_K = 0._wp + + alpha_K_sum = 0._wp + + if (mpp_lim) then + do i = 1, num_fluids + alpha_rho_K(i) = max(0._wp, alpha_rho_K(i)) + alpha_K(i) = min(max(0._wp, alpha_K(i)), 1._wp) + alpha_K_sum = alpha_K_sum + alpha_K(i) + end do + + alpha_K = alpha_K/max(alpha_K_sum, sgm_eps) + + end if + + do i = 1, num_fluids + rho_K = rho_K + alpha_rho_K(i) + gamma_K = gamma_K + alpha_K(i)*gammas(i) + pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) + qv_K = qv_K + alpha_rho_K(i)*qvs(i) + end do + + if (present(G_K)) then + G_K = 0._wp + do i = 1, num_fluids + !TODO: change to use Gs directly here? + !TODO: Make this changes as well for GPUs + G_K = G_K + alpha_K(i)*G(i) + end do + G_K = max(0._wp, G_K) + end if + + if (viscous) then + + do i = 1, 2 + Re_K(i) = dflt_real + + if (Re_size(i) > 0) Re_K(i) = 0._wp + + do j = 1, Re_size(i) + Re_K(i) = alpha_K(Re_idx(i, j))/Res(i, j) & + + Re_K(i) + end do + + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) + + end do + end if +#endif + + end subroutine s_convert_species_to_mixture_variables_acc + + pure subroutine s_convert_species_to_mixture_variables_bubbles_acc(rho_K, & + gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, k, l, r) +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_convert_species_to_mixture_variables_bubbles_acc +#else + !$acc routine seq +#endif + + real(wp), intent(inout) :: rho_K, gamma_K, pi_inf_K, qv_K + + real(wp), dimension(num_fluids), intent(in) :: alpha_K, alpha_rho_K !< + !! Partial densities and volume fractions + + real(wp), dimension(2), intent(out) :: Re_K + integer, intent(in) :: k, l, r + + integer :: i, j !< Generic loop iterators + +#ifdef MFC_SIMULATION + rho_K = 0._wp + gamma_K = 0._wp + pi_inf_K = 0._wp + qv_K = 0._wp + + if (mpp_lim .and. (model_eqns == 2) .and. (num_fluids > 2)) then + do i = 1, num_fluids + rho_K = rho_K + alpha_rho_K(i) + gamma_K = gamma_K + alpha_K(i)*gammas(i) + pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) + qv_K = qv_K + alpha_rho_K(i)*qvs(i) + end do + else if ((model_eqns == 2) .and. (num_fluids > 2)) then + do i = 1, num_fluids - 1 + rho_K = rho_K + alpha_rho_K(i) + gamma_K = gamma_K + alpha_K(i)*gammas(i) + pi_inf_K = pi_inf_K + alpha_K(i)*pi_infs(i) + qv_K = qv_K + alpha_rho_K(i)*qvs(i) + end do + else + rho_K = alpha_rho_K(1) + gamma_K = gammas(1) + pi_inf_K = pi_infs(1) + qv_K = qvs(1) + end if + + if (viscous) then + if (num_fluids == 1) then ! need to consider case with num_fluids >= 2 + + do i = 1, 2 + Re_K(i) = dflt_real + + if (Re_size(i) > 0) Re_K(i) = 0._wp + + do j = 1, Re_size(i) + Re_K(i) = (1._wp - alpha_K(Re_idx(i, j)))/Res(i, j) & + + Re_K(i) + end do + + Re_K(i) = 1._wp/max(Re_K(i), sgm_eps) + + end do + end if + end if +#endif + + end subroutine s_convert_species_to_mixture_variables_bubbles_acc + + !> The computation of parameters, the allocation of memory, + !! the association of pointers and/or the execution of any + !! other procedures that are necessary to setup the module. + impure subroutine s_initialize_variables_conversion_module + + integer :: i, j + +!$acc enter data copyin(is1b, is1e, is2b, is2e, is3b, is3e) + +#ifdef MFC_SIMULATION + @:ALLOCATE(gammas (1:num_fluids)) + @:ALLOCATE(gs_min (1:num_fluids)) + @:ALLOCATE(pi_infs(1:num_fluids)) + @:ALLOCATE(ps_inf(1:num_fluids)) + @:ALLOCATE(cvs (1:num_fluids)) + @:ALLOCATE(qvs (1:num_fluids)) + @:ALLOCATE(qvps (1:num_fluids)) + @:ALLOCATE(Gs (1:num_fluids)) +#else + @:ALLOCATE(gammas (1:num_fluids)) + @:ALLOCATE(gs_min (1:num_fluids)) + @:ALLOCATE(pi_infs(1:num_fluids)) + @:ALLOCATE(ps_inf(1:num_fluids)) + @:ALLOCATE(cvs (1:num_fluids)) + @:ALLOCATE(qvs (1:num_fluids)) + @:ALLOCATE(qvps (1:num_fluids)) + @:ALLOCATE(Gs (1:num_fluids)) +#endif + + do i = 1, num_fluids + gammas(i) = fluid_pp(i)%gamma + gs_min(i) = 1.0_wp/gammas(i) + 1.0_wp + pi_infs(i) = fluid_pp(i)%pi_inf + Gs(i) = fluid_pp(i)%G + ps_inf(i) = pi_infs(i)/(1.0_wp + gammas(i)) + cvs(i) = fluid_pp(i)%cv + qvs(i) = fluid_pp(i)%qv + qvps(i) = fluid_pp(i)%qvp + end do +!$acc update device(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) + +#ifdef MFC_SIMULATION + + if (viscous) then + @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) + do i = 1, 2 + do j = 1, Re_size(i) + Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) + end do + end do + + !$acc update device(Res, Re_idx, Re_size) + end if +#endif + + if (bubbles_euler) then +#ifdef MFC_SIMULATION + @:ALLOCATE(bubrs(1:nb)) +#else + @:ALLOCATE(bubrs(1:nb)) +#endif + + do i = 1, nb + bubrs(i) = bub_idx%rs(i) + end do + !$acc update device(bubrs) + end if + +#ifdef MFC_POST_PROCESS + ! Allocating the density, the specific heat ratio function and the + ! liquid stiffness function, respectively + + ! Simulation is at least 2D + if (n > 0) then + + ! Simulation is 3D + if (p > 0) then + + allocate (rho_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + -buff_size:p + buff_size)) + allocate (gamma_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + -buff_size:p + buff_size)) + allocate (pi_inf_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + -buff_size:p + buff_size)) + allocate (qv_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + -buff_size:p + buff_size)) + + ! Simulation is 2D + else + + allocate (rho_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + 0:0)) + allocate (gamma_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + 0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + 0:0)) + allocate (qv_sf(-buff_size:m + buff_size, & + -buff_size:n + buff_size, & + 0:0)) + end if + + ! Simulation is 1D + else + + allocate (rho_sf(-buff_size:m + buff_size, & + 0:0, & + 0:0)) + allocate (gamma_sf(-buff_size:m + buff_size, & + 0:0, & + 0:0)) + allocate (pi_inf_sf(-buff_size:m + buff_size, & + 0:0, & + 0:0)) + allocate (qv_sf(-buff_size:m + buff_size, & + 0:0, & + 0:0)) + + end if +#endif + + end subroutine s_initialize_variables_conversion_module + + !Initialize mv at the quadrature nodes based on the initialized moments and sigma + pure subroutine s_initialize_mv(qK_cons_vf, mv) + + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + + real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: mv + + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc + + do l = idwint(3)%beg, idwint(3)%end + do k = idwint(2)%beg, idwint(2)%end + do j = idwint(1)%beg, idwint(1)%end + + nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) + + !$acc loop seq + do i = 1, nb + mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc + sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5_wp + + mv(j, k, l, 1, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 2, i) = (mass_v0(i))*(mu - sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 3, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) + mv(j, k, l, 4, i) = (mass_v0(i))*(mu + sig)**(3._wp)/(R0(i)**(3._wp)) + end do + + end do + end do + end do + + end subroutine s_initialize_mv + + !Initialize pb at the quadrature nodes using isothermal relations (Preston model) + pure subroutine s_initialize_pb(qK_cons_vf, mv, pb) + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + + real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(in) :: mv + real(wp), dimension(idwint(1)%beg:, idwint(2)%beg:, idwint(3)%beg:, 1:, 1:), intent(inout) :: pb + + integer :: i, j, k, l + real(wp) :: mu, sig, nbub_sc + + do l = idwint(3)%beg, idwint(3)%end + do k = idwint(2)%beg, idwint(2)%end + do j = idwint(1)%beg, idwint(1)%end + + nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) + + !$acc loop seq + do i = 1, nb + mu = qK_cons_vf(bubxb + 1 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc + sig = (qK_cons_vf(bubxb + 3 + (i - 1)*nmom)%sf(j, k, l)/nbub_sc - mu**2)**0.5_wp + + !PRESTON (ISOTHERMAL) + pb(j, k, l, 1, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 1, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 2, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 2, i))/(mu - sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 3, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 3, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + pb(j, k, l, 4, i) = (pb0(i))*(R0(i)**(3._wp))*(mass_n0(i) + mv(j, k, l, 4, i))/(mu + sig)**(3._wp)/(mass_n0(i) + mass_v0(i)) + end do + end do + end do + end do + + end subroutine s_initialize_pb + + !> The following procedure handles the conversion between + !! the conservative variables and the primitive variables. + !! @param qK_cons_vf Conservative variables + !! @param qK_prim_vf Primitive variables + !! @param gm_alphaK_vf Gradient magnitude of the volume fraction + !! @param ix Index bounds in first coordinate direction + !! @param iy Index bounds in second coordinate direction + !! @param iz Index bounds in third coordinate direction + subroutine s_convert_conservative_to_primitive_variables(qK_cons_vf, & + q_T_sf, & + qK_prim_vf, & + ibounds, & + gm_alphaK_vf) + + type(scalar_field), dimension(sys_size), intent(in) :: qK_cons_vf + type(scalar_field), intent(inout) :: q_T_sf + type(scalar_field), dimension(sys_size), intent(inout) :: qK_prim_vf + type(int_bounds_info), dimension(1:3), intent(in) :: ibounds + type(scalar_field), & + allocatable, optional, dimension(:), & + intent(in) :: gm_alphaK_vf + + real(wp), dimension(num_fluids) :: alpha_K, alpha_rho_K + real(wp), dimension(2) :: Re_K + real(wp) :: rho_K, gamma_K, pi_inf_K, qv_K, dyn_pres_K + + #:if MFC_CASE_OPTIMIZATION +#ifndef MFC_SIMULATION + real(wp), dimension(:), allocatable :: nRtmp +#else + real(wp), dimension(nb) :: nRtmp +#endif + #:else + real(wp), dimension(:), allocatable :: nRtmp + #:endif + + real(wp) :: rhoYks(1:num_species) + + real(wp) :: vftmp, nbub_sc + + real(wp) :: G_K + + real(wp) :: pres + + integer :: i, j, k, l !< Generic loop iterators + + real(wp) :: T + real(wp) :: pres_mag + + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: B2 ! Magnetic field magnitude squared + real(wp) :: B(3) ! Magnetic field components + real(wp) :: m2 ! Relativistic momentum magnitude squared + real(wp) :: S ! Dot product of the magnetic field and the relativistic momentum + real(wp) :: W, dW ! W := rho*v*Ga**2; f = f(W) in Newton-Raphson + real(wp) :: E, D ! Prim/Cons variables within Newton-Raphson iteration + real(wp) :: f, dGa_dW, dp_dW, df_dW ! Functions within Newton-Raphson iteration + integer :: iter ! Newton-Raphson iteration counter + + #:if MFC_CASE_OPTIMIZATION +#ifndef MFC_SIMULATION + if (bubbles_euler) then + allocate (nRtmp(nb)) + else + allocate (nRtmp(0)) + end if +#endif + #:else + if (bubbles_euler) then + allocate (nRtmp(nb)) + else + allocate (nRtmp(0)) + end if + #:endif + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(alpha_K, alpha_rho_K, Re_K, nRtmp, rho_K, gamma_K, & + !$acc pi_inf_K, qv_K, dyn_pres_K, rhoYks, B) + do l = ibounds(3)%beg, ibounds(3)%end + do k = ibounds(2)%beg, ibounds(2)%end + do j = ibounds(1)%beg, ibounds(1)%end + dyn_pres_K = 0._wp + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_K(i) = qK_cons_vf(i)%sf(j, k, l) + alpha_K(i) = qK_cons_vf(advxb + i - 1)%sf(j, k, l) + end do + + if (model_eqns /= 4) then +#ifdef MFC_SIMULATION + ! If in simulation, use acc mixture subroutines + if (elasticity) then + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, alpha_K, & + alpha_rho_K, Re_K, j, k, l, G_K, Gs) + else if (bubbles_euler) then + call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, j, k, l) + else + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, j, k, l) + end if +#else + ! If pre-processing, use non acc mixture subroutines + if (elasticity) then + call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & + rho_K, gamma_K, pi_inf_K, qv_K, Re_K, G_K, fluid_pp(:)%G) + else + call s_convert_to_mixture_variables(qK_cons_vf, j, k, l, & + rho_K, gamma_K, pi_inf_K, qv_K) + end if +#endif + end if + + if (relativity) then + if (n == 0) then + B(1) = Bx0 + B(2) = qK_cons_vf(B_idx%beg)%sf(j, k, l) + B(3) = qK_cons_vf(B_idx%beg + 1)%sf(j, k, l) + else + B(1) = qK_cons_vf(B_idx%beg)%sf(j, k, l) + B(2) = qK_cons_vf(B_idx%beg + 1)%sf(j, k, l) + B(3) = qK_cons_vf(B_idx%beg + 2)%sf(j, k, l) + end if + B2 = B(1)**2 + B(2)**2 + B(3)**2 + + m2 = 0._wp + !$acc loop seq + do i = momxb, momxe + m2 = m2 + qK_cons_vf(i)%sf(j, k, l)**2 + end do + + S = 0._wp + !$acc loop seq + do i = 1, 3 + S = S + qK_cons_vf(momxb + i - 1)%sf(j, k, l)*B(i) + end do + + E = qK_cons_vf(E_idx)%sf(j, k, l) + + D = 0._wp + !$acc loop seq + do i = 1, contxe + D = D + qK_cons_vf(i)%sf(j, k, l) + end do + + ! Newton-Raphson + W = E + D + !$acc loop seq + do iter = 1, relativity_cons_to_prim_max_iter + Ga = (W + B2)*W/sqrt((W + B2)**2*W**2 - (m2*W**2 + S**2*(2*W + B2))) + pres = (W - D*Ga)/((gamma_K + 1)*Ga**2) ! Thermal pressure from EOS + f = W - pres + (1 - 1/(2*Ga**2))*B2 - S**2/(2*W**2) - E - D + + ! The first equation below corrects a typo in (Mignone & Bodo, 2006) + ! m2*W**2 → 2*m2*W**2, which would cancel with the 2* in other terms + ! This corrected version is not used as the second equation empirically converges faster. + ! First equation is kept for further investigation. + ! dGa_dW = -Ga**3 * ( S**2*(3*W**2+3*W*B2+B2**2) + m2*W**2 ) / (W**3 * (W+B2)**3) ! first (corrected) + dGa_dW = -Ga**3*(2*S**2*(3*W**2 + 3*W*B2 + B2**2) + m2*W**2)/(2*W**3*(W + B2)**3) ! second (in paper) + + dp_dW = (Ga*(1 + D*dGa_dW) - 2*W*dGa_dW)/((gamma_K + 1)*Ga**3) + df_dW = 1 - dp_dW + (B2/Ga**3)*dGa_dW + S**2/W**3 + + dW = -f/df_dW + W = W + dW + if (abs(dW) < 1e-12*W) exit + end do + + ! Recalculate pressure using converged W + Ga = (W + B2)*W/sqrt((W + B2)**2*W**2 - (m2*W**2 + S**2*(2*W + B2))) + qK_prim_vf(E_idx)%sf(j, k, l) = (W - D*Ga)/((gamma_K + 1)*Ga**2) + + ! Recover the other primitive variables + !$acc loop seq + do i = 1, 3 + qK_prim_vf(momxb + i - 1)%sf(j, k, l) = (qK_cons_vf(momxb + i - 1)%sf(j, k, l) + (S/W)*B(i))/(W + B2) + end do + qK_prim_vf(1)%sf(j, k, l) = D/Ga ! Hard-coded for single-component for now + + !$acc loop seq + do i = B_idx%beg, B_idx%end + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) + end do + + cycle ! skip all the non-relativistic conversions below + end if + + if (chemistry) then + rho_K = 0._wp + !$acc loop seq + do i = chemxb, chemxe + rho_K = rho_K + max(0._wp, qK_cons_vf(i)%sf(j, k, l)) + end do + + !$acc loop seq + do i = 1, contxe + qK_prim_vf(i)%sf(j, k, l) = rho_K + end do + + !$acc loop seq + do i = chemxb, chemxe + qK_prim_vf(i)%sf(j, k, l) = max(0._wp, qK_cons_vf(i)%sf(j, k, l)/rho_K) + end do + else + !$acc loop seq + do i = 1, contxe + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) + end do + end if + +#ifdef MFC_SIMULATION + rho_K = max(rho_K, sgm_eps) +#endif + + !$acc loop seq + do i = momxb, momxe + if (model_eqns /= 4) then + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & + /rho_K + dyn_pres_K = dyn_pres_K + 5e-1_wp*qK_cons_vf(i)%sf(j, k, l) & + *qK_prim_vf(i)%sf(j, k, l) + else + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) & + /qK_cons_vf(1)%sf(j, k, l) + end if + end do + + if (chemistry) then + !$acc loop seq + do i = 1, num_species + rhoYks(i) = qK_cons_vf(chemxb + i - 1)%sf(j, k, l) + end do + + T = q_T_sf%sf(j, k, l) + end if + + if (mhd) then + if (n == 0) then + pres_mag = 0.5_wp*(Bx0**2 + qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2) + else + pres_mag = 0.5_wp*(qK_cons_vf(B_idx%beg)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 1)%sf(j, k, l)**2 + qK_cons_vf(B_idx%beg + 2)%sf(j, k, l)**2) + end if + else + pres_mag = 0._wp + end if + + call s_compute_pressure(qK_cons_vf(E_idx)%sf(j, k, l), & + qK_cons_vf(alf_idx)%sf(j, k, l), & + dyn_pres_K, pi_inf_K, gamma_K, rho_K, & + qv_K, rhoYks, pres, T, pres_mag=pres_mag) + + qK_prim_vf(E_idx)%sf(j, k, l) = pres + + if (chemistry) then + q_T_sf%sf(j, k, l) = T + end if + + if (bubbles_euler) then + !$acc loop seq + do i = 1, nb + nRtmp(i) = qK_cons_vf(bubrs(i))%sf(j, k, l) + end do + + vftmp = qK_cons_vf(alf_idx)%sf(j, k, l) + + if (qbmm) then + !Get nb (constant across all R0 bins) + nbub_sc = qK_cons_vf(bubxb)%sf(j, k, l) + + !Convert cons to prim + !$acc loop seq + do i = bubxb, bubxe + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc + end do + !Need to keep track of nb in the primitive variable list (converted back to true value before output) +#ifdef MFC_SIMULATION + qK_prim_vf(bubxb)%sf(j, k, l) = qK_cons_vf(bubxb)%sf(j, k, l) +#endif + + else + if (adv_n) then + qK_prim_vf(n_idx)%sf(j, k, l) = qK_cons_vf(n_idx)%sf(j, k, l) + nbub_sc = qK_prim_vf(n_idx)%sf(j, k, l) + else + call s_comp_n_from_cons(vftmp, nRtmp, nbub_sc, weight) + end if + + !$acc loop seq + do i = bubxb, bubxe + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/nbub_sc + end do + end if + end if + + if (mhd) then + !$acc loop seq + do i = B_idx%beg, B_idx%end + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) + end do + end if + + if (elasticity) then + !$acc loop seq + do i = strxb, strxe + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K + end do + end if + + if (hypoelasticity) then + !$acc loop seq + do i = strxb, strxe + ! subtracting elastic contribution for pressure calculation + if (G_K > verysmall) then + if (cont_damage) G_K = G_K*max((1._wp - qK_cons_vf(damage_idx)%sf(j, k, l)), 0._wp) + qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & + ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K + ! Double for shear stresses + if (any(i == shear_indices)) then + qK_prim_vf(E_idx)%sf(j, k, l) = qK_prim_vf(E_idx)%sf(j, k, l) - & + ((qK_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G_K))/gamma_K + end if + end if + end do + end if + + if (hyperelasticity) then + !$acc loop seq + do i = xibeg, xiend + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l)/rho_K + end do + end if + + !$acc loop seq + do i = advxb, advxe + qK_prim_vf(i)%sf(j, k, l) = qK_cons_vf(i)%sf(j, k, l) + end do + + if (surface_tension) then + qK_prim_vf(c_idx)%sf(j, k, l) = qK_cons_vf(c_idx)%sf(j, k, l) + end if + + if (cont_damage) qK_prim_vf(damage_idx)%sf(j, k, l) = qK_cons_vf(damage_idx)%sf(j, k, l) + + end do + end do + end do + !$acc end parallel loop + + end subroutine s_convert_conservative_to_primitive_variables + + !> The following procedure handles the conversion between + !! the primitive variables and the conservative variables. + !! @param qK_prim_vf Primitive variables + !! @param qK_cons_vf Conservative variables + !! @param gm_alphaK_vf Gradient magnitude of the volume fractions + !! @param ix Index bounds in the first coordinate direction + !! @param iy Index bounds in the second coordinate direction + !! @param iz Index bounds in the third coordinate direction + impure subroutine s_convert_primitive_to_conservative_variables(q_prim_vf, & + q_cons_vf) + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: q_cons_vf + + ! Density, specific heat ratio function, liquid stiffness function + ! and dynamic pressure, as defined in the incompressible flow sense, + ! respectively + real(wp) :: rho + real(wp) :: gamma + real(wp) :: pi_inf + real(wp) :: qv + real(wp) :: dyn_pres + real(wp) :: nbub, R3tmp + real(wp), dimension(nb) :: Rtmp + real(wp) :: G + real(wp), dimension(2) :: Re_K + + integer :: i, j, k, l !< Generic loop iterators + + real(wp), dimension(num_species) :: Ys + real(wp) :: e_mix, mix_mol_weight, T + real(wp) :: pres_mag + + real(wp) :: Ga ! Lorentz factor (gamma in relativity) + real(wp) :: h ! relativistic enthalpy + real(wp) :: v2 ! Square of the velocity magnitude + real(wp) :: B2 ! Square of the magnetic field magnitude + real(wp) :: vdotB ! Dot product of the velocity and magnetic field vectors + real(wp) :: B(3) ! Magnetic field components + + pres_mag = 0._wp + + G = 0._wp + +#ifndef MFC_SIMULATION + ! Converting the primitive variables to the conservative variables + do l = 0, p + do k = 0, n + do j = 0, m + + ! Obtaining the density, specific heat ratio function + ! and the liquid stiffness function, respectively + call s_convert_to_mixture_variables(q_prim_vf, j, k, l, & + rho, gamma, pi_inf, qv, Re_K, G, fluid_pp(:)%G) + + ! Transferring the advection equation(s) variable(s) + do i = adv_idx%beg, adv_idx%end + q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) + end do + + if (relativity) then + + if (n == 0) then + B(1) = Bx0 + B(2) = q_prim_vf(B_idx%beg)%sf(j, k, l) + B(3) = q_prim_vf(B_idx%beg + 1)%sf(j, k, l) + else + B(1) = q_prim_vf(B_idx%beg)%sf(j, k, l) + B(2) = q_prim_vf(B_idx%beg + 1)%sf(j, k, l) + B(3) = q_prim_vf(B_idx%beg + 2)%sf(j, k, l) + end if + + v2 = 0._wp + do i = momxb, momxe + v2 = v2 + q_prim_vf(i)%sf(j, k, l)**2 + end do + if (v2 >= 1._wp) call s_mpi_abort('Error: v squared > 1 in s_convert_primitive_to_conservative_variables') + + Ga = 1._wp/sqrt(1._wp - v2) + + h = 1._wp + (gamma + 1)*q_prim_vf(E_idx)%sf(j, k, l)/rho ! Assume perfect gas for now + + B2 = 0._wp + do i = B_idx%beg, B_idx%end + B2 = B2 + q_prim_vf(i)%sf(j, k, l)**2 + end do + if (n == 0) B2 = B2 + Bx0**2 + + vdotB = 0._wp + do i = 1, 3 + vdotB = vdotB + q_prim_vf(momxb + i - 1)%sf(j, k, l)*B(i) + end do + + do i = 1, contxe + q_cons_vf(i)%sf(j, k, l) = Ga*q_prim_vf(i)%sf(j, k, l) + end do + + do i = momxb, momxe + q_cons_vf(i)%sf(j, k, l) = (rho*h*Ga**2 + B2)*q_prim_vf(i)%sf(j, k, l) & + - vdotB*B(i - momxb + 1) + end do + + q_cons_vf(E_idx)%sf(j, k, l) = rho*h*Ga**2 - q_prim_vf(E_idx)%sf(j, k, l) & + + 0.5_wp*(B2 + v2*B2 - vdotB**2) + ! Remove rest energy + do i = 1, contxe + q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) - q_cons_vf(i)%sf(j, k, l) + end do + + do i = B_idx%beg, B_idx%end + q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) + end do + + cycle ! skip all the non-relativistic conversions below + + end if + + ! Transferring the continuity equation(s) variable(s) + do i = 1, contxe + q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) + end do + + ! Zeroing out the dynamic pressure since it is computed + ! iteratively by cycling through the velocity equations + dyn_pres = 0._wp + + ! Computing momenta and dynamic pressure from velocity + do i = momxb, momxe + q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) + dyn_pres = dyn_pres + q_cons_vf(i)%sf(j, k, l)* & + q_prim_vf(i)%sf(j, k, l)/2._wp + end do + + if (chemistry) then + do i = chemxb, chemxe + Ys(i - chemxb + 1) = q_prim_vf(i)%sf(j, k, l) + q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) + end do + + call get_mixture_molecular_weight(Ys, mix_mol_weight) + T = q_prim_vf(E_idx)%sf(j, k, l)*mix_mol_weight/(gas_constant*rho) + call get_mixture_energy_mass(T, Ys, e_mix) + + q_cons_vf(E_idx)%sf(j, k, l) = & + dyn_pres + rho*e_mix + else + ! Computing the energy from the pressure + if (mhd) then + if (n == 0) then + pres_mag = 0.5_wp*(Bx0**2 + q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2) + else + pres_mag = 0.5_wp*(q_prim_vf(B_idx%beg)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 1)%sf(j, k, l)**2 + q_prim_vf(B_idx%beg + 2)%sf(j, k, l)**2) + end if + q_cons_vf(E_idx)%sf(j, k, l) = & + gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pres_mag & + + pi_inf + qv + elseif ((model_eqns /= 4) .and. (bubbles_euler .neqv. .true.)) then + ! E = Gamma*P + \rho u u /2 + \pi_inf + (\alpha\rho qv) + q_cons_vf(E_idx)%sf(j, k, l) = & + gamma*q_prim_vf(E_idx)%sf(j, k, l) + dyn_pres + pi_inf & + + qv + else if ((model_eqns /= 4) .and. (bubbles_euler)) then + ! \tilde{E} = dyn_pres + (1-\alf)(\Gamma p_l + \Pi_inf) + q_cons_vf(E_idx)%sf(j, k, l) = dyn_pres + & + (1._wp - q_prim_vf(alf_idx)%sf(j, k, l))* & + (gamma*q_prim_vf(E_idx)%sf(j, k, l) + pi_inf) + else + !Tait EOS, no conserved energy variable + q_cons_vf(E_idx)%sf(j, k, l) = 0._wp + end if + end if + + ! Computing the internal energies from the pressure and continuities + if (model_eqns == 3) then + do i = 1, num_fluids + ! internal energy calculation for each of the fluids + q_cons_vf(i + internalEnergies_idx%beg - 1)%sf(j, k, l) = & + q_cons_vf(i + adv_idx%beg - 1)%sf(j, k, l)* & + (fluid_pp(i)%gamma*q_prim_vf(E_idx)%sf(j, k, l) + & + fluid_pp(i)%pi_inf) + & + q_cons_vf(i + cont_idx%beg - 1)%sf(j, k, l)*fluid_pp(i)%qv + end do + end if + + if (bubbles_euler) then + ! From prim: Compute nbub = (3/4pi) * \alpha / \bar{R^3} + do i = 1, nb + Rtmp(i) = q_prim_vf(bub_idx%rs(i))%sf(j, k, l) + end do + + if (.not. qbmm) then + if (adv_n) then + q_cons_vf(n_idx)%sf(j, k, l) = q_prim_vf(n_idx)%sf(j, k, l) + nbub = q_prim_vf(n_idx)%sf(j, k, l) + else + call s_comp_n_from_prim(q_prim_vf(alf_idx)%sf(j, k, l), Rtmp, nbub, weight) + end if + else + !Initialize R3 averaging over R0 and R directions + R3tmp = 0._wp + do i = 1, nb + R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) + sigR)**3._wp + R3tmp = R3tmp + weight(i)*0.5_wp*(Rtmp(i) - sigR)**3._wp + end do + !Initialize nb + nbub = 3._wp*q_prim_vf(alf_idx)%sf(j, k, l)/(4._wp*pi*R3tmp) + end if + + if (j == 0 .and. k == 0 .and. l == 0) print *, 'In convert, nbub:', nbub + + do i = bub_idx%beg, bub_idx%end + q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l)*nbub + end do + end if + + if (mhd) then + do i = B_idx%beg, B_idx%end + q_cons_vf(i)%sf(j, k, l) = q_prim_vf(i)%sf(j, k, l) + end do + end if + + if (elasticity) then + ! adding the elastic contribution + ! Multiply \tau to \rho \tau + do i = strxb, strxe + q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) + end do + end if + + if (hypoelasticity) then + do i = strxb, strxe + ! adding elastic contribution + if (G > verysmall) then + if (cont_damage) G = G*max((1._wp - q_prim_vf(damage_idx)%sf(j, k, l)), 0._wp) + + q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & + (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) + ! Double for shear stresses + if (any(i == shear_indices)) then + q_cons_vf(E_idx)%sf(j, k, l) = q_cons_vf(E_idx)%sf(j, k, l) + & + (q_prim_vf(i)%sf(j, k, l)**2._wp)/(4._wp*G) + end if + end if + end do + end if + + ! using \rho xi as the conservative formulation stated in Kamrin et al. JFM 2022 + if (hyperelasticity) then + ! Multiply \xi to \rho \xi + do i = xibeg, xiend + q_cons_vf(i)%sf(j, k, l) = rho*q_prim_vf(i)%sf(j, k, l) + end do + end if + + if (surface_tension) then + q_cons_vf(c_idx)%sf(j, k, l) = q_prim_vf(c_idx)%sf(j, k, l) + end if + + if (cont_damage) q_cons_vf(damage_idx)%sf(j, k, l) = q_prim_vf(damage_idx)%sf(j, k, l) + + end do + end do + end do +#else + if (proc_rank == 0) then + call s_mpi_abort('Conversion from primitive to '// & + 'conservative variables not '// & + 'implemented. Exiting.') + end if +#endif + end subroutine s_convert_primitive_to_conservative_variables + + !> The following subroutine handles the conversion between + !! the primitive variables and the Eulerian flux variables. + !! @param qK_prim_vf Primitive variables + !! @param FK_vf Flux variables + !! @param FK_src_vf Flux source variables + !! @param ix Index bounds in the first coordinate direction + !! @param iy Index bounds in the second coordinate direction + !! @param iz Index bounds in the third coordinate direction + subroutine s_convert_primitive_to_flux_variables(qK_prim_vf, & + FK_vf, & + FK_src_vf, & + is1, is2, is3, s2b, s3b) + + integer, intent(in) :: s2b, s3b + real(wp), dimension(0:, s2b:, s3b:, 1:), intent(in) :: qK_prim_vf + real(wp), dimension(0:, s2b:, s3b:, 1:), intent(inout) :: FK_vf + real(wp), dimension(0:, s2b:, s3b:, advxb:), intent(inout) :: FK_src_vf + + type(int_bounds_info), intent(in) :: is1, is2, is3 + + ! Partial densities, density, velocity, pressure, energy, advection + ! variables, the specific heat ratio and liquid stiffness functions, + ! the shear and volume Reynolds numbers and the Weber numbers + real(wp), dimension(num_fluids) :: alpha_rho_K + real(wp), dimension(num_fluids) :: alpha_K + real(wp) :: rho_K + real(wp), dimension(num_vels) :: vel_K + real(wp) :: vel_K_sum + real(wp) :: pres_K + real(wp) :: E_K + real(wp) :: gamma_K + real(wp) :: pi_inf_K + real(wp) :: qv_K + real(wp), dimension(2) :: Re_K + real(wp) :: G_K + real(wp), dimension(num_species) :: Y_K + real(wp) :: T_K, mix_mol_weight, R_gas + + integer :: i, j, k, l !< Generic loop iterators + + is1b = is1%beg; is1e = is1%end + is2b = is2%beg; is2e = is2%end + is3b = is3%beg; is3e = is3%end + + !$acc update device(is1b, is2b, is3b, is1e, is2e, is3e) + + ! Computing the flux variables from the primitive variables, without + ! accounting for the contribution of either viscosity or capillarity +#ifdef MFC_SIMULATION + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_K, vel_K, alpha_K, Re_K, Y_K) + do l = is3b, is3e + do k = is2b, is2e + do j = is1b, is1e + + !$acc loop seq + do i = 1, contxe + alpha_rho_K(i) = qK_prim_vf(j, k, l, i) + end do + + !$acc loop seq + do i = advxb, advxe + alpha_K(i - E_idx) = qK_prim_vf(j, k, l, i) + end do + !$acc loop seq + do i = 1, num_vels + vel_K(i) = qK_prim_vf(j, k, l, contxe + i) + end do + + vel_K_sum = 0._wp + !$acc loop seq + do i = 1, num_vels + vel_K_sum = vel_K_sum + vel_K(i)**2._wp + end do + + pres_K = qK_prim_vf(j, k, l, E_idx) + if (elasticity) then + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, & + j, k, l, G_K, Gs) + else if (bubbles_euler) then + call s_convert_species_to_mixture_variables_bubbles_acc(rho_K, gamma_K, & + pi_inf_K, qv_K, alpha_K, alpha_rho_K, Re_K, j, k, l) + else + call s_convert_species_to_mixture_variables_acc(rho_K, gamma_K, pi_inf_K, qv_K, & + alpha_K, alpha_rho_K, Re_K, j, k, l) + end if + + ! Computing the energy from the pressure + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Y_K(i - chemxb + 1) = qK_prim_vf(j, k, l, i) + end do + !Computing the energy from the internal energy of the mixture + call get_mixture_molecular_weight(Y_k, mix_mol_weight) + R_gas = gas_constant/mix_mol_weight + T_K = pres_K/rho_K/R_gas + call get_mixture_energy_mass(T_K, Y_K, E_K) + E_K = rho_K*E_K + 5e-1_wp*rho_K*vel_K_sum + else + ! Computing the energy from the pressure + E_K = gamma_K*pres_K + pi_inf_K & + + 5e-1_wp*rho_K*vel_K_sum + qv_K + end if + + ! mass flux, this should be \alpha_i \rho_i u_i + !$acc loop seq + do i = 1, contxe + FK_vf(j, k, l, i) = alpha_rho_K(i)*vel_K(dir_idx(1)) + end do + + !$acc loop seq + do i = 1, num_vels + FK_vf(j, k, l, contxe + dir_idx(i)) = & + rho_K*vel_K(dir_idx(1)) & + *vel_K(dir_idx(i)) & + + pres_K*dir_flg(dir_idx(i)) + end do + + ! energy flux, u(E+p) + FK_vf(j, k, l, E_idx) = vel_K(dir_idx(1))*(E_K + pres_K) + + ! Species advection Flux, \rho*u*Y + if (chemistry) then + !$acc loop seq + do i = 1, num_species + FK_vf(j, k, l, i - 1 + chemxb) = vel_K(dir_idx(1))*(rho_K*Y_K(i)) + end do + end if + + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc loop seq + do i = advxb, advxe + FK_vf(j, k, l, i) = 0._wp + FK_src_vf(j, k, l, i) = alpha_K(i - E_idx) + end do + + else + ! Could be bubbles_euler! + !$acc loop seq + do i = advxb, advxe + FK_vf(j, k, l, i) = vel_K(dir_idx(1))*alpha_K(i - E_idx) + end do + + !$acc loop seq + do i = advxb, advxe + FK_src_vf(j, k, l, i) = vel_K(dir_idx(1)) + end do + + end if + + end do + end do + end do +#endif + end subroutine s_convert_primitive_to_flux_variables + + impure subroutine s_finalize_variables_conversion_module() + + ! Deallocating the density, the specific heat ratio function and the + ! liquid stiffness function +#ifdef MFC_POST_PROCESS + deallocate (rho_sf, gamma_sf, pi_inf_sf, qv_sf) +#endif + +#ifdef MFC_SIMULATION + @:DEALLOCATE(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) + if (bubbles_euler) then + @:DEALLOCATE(bubrs) + end if +#else + @:DEALLOCATE(gammas, gs_min, pi_infs, ps_inf, cvs, qvs, qvps, Gs) + if (bubbles_euler) then + @:DEALLOCATE(bubrs) + end if +#endif + + end subroutine s_finalize_variables_conversion_module + +#ifndef MFC_PRE_PROCESS + pure subroutine s_compute_speed_of_sound(pres, rho, gamma, pi_inf, H, adv, vel_sum, c_c, c) +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_speed_of_sound +#else + !$acc routine seq +#endif + + real(wp), intent(in) :: pres + real(wp), intent(in) :: rho, gamma, pi_inf + real(wp), intent(in) :: H + real(wp), dimension(num_fluids), intent(in) :: adv + real(wp), intent(in) :: vel_sum + real(wp), intent(in) :: c_c + real(wp), intent(out) :: c + + real(wp) :: blkmod1, blkmod2 + real(wp) :: Tolerance + + integer :: q + + if (chemistry) then + if (avg_state == 1 .and. abs(c_c) > Tolerance) then + c = sqrt(c_c - (gamma - 1.0_wp)*(vel_sum - H)) + else + c = sqrt((1.0_wp + 1.0_wp/gamma)*pres/rho) + end if + elseif (relativity) then + ! Only supports perfect gas for now + c = sqrt((1._wp + 1._wp/gamma)*pres/rho/H) + else + if (alt_soundspeed) then + blkmod1 = ((gammas(1) + 1._wp)*pres + & + pi_infs(1))/gammas(1) + blkmod2 = ((gammas(2) + 1._wp)*pres + & + pi_infs(2))/gammas(2) + c = (1._wp/(rho*(adv(1)/blkmod1 + adv(2)/blkmod2))) + elseif (model_eqns == 3) then + c = 0._wp + !$acc loop seq + do q = 1, num_fluids + c = c + adv(q)*(1._wp/gammas(q) + 1._wp)* & + (pres + pi_infs(q)/(gammas(q) + 1._wp)) + end do + c = c/rho + elseif (((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles_euler))) then + ! Sound speed for bubble mmixture to order O(\alpha) + + if (mpp_lim .and. (num_fluids > 1)) then + c = (1._wp/gamma + 1._wp)* & + (pres + pi_inf/(gamma + 1._wp))/rho + else + c = & + (1._wp/gamma + 1._wp)* & + (pres + pi_inf/(gamma + 1._wp))/ & + (rho*(1._wp - adv(num_fluids))) + end if + else + c = ((H - 5e-1*vel_sum)/gamma) + end if + + if (mixture_err .and. c < 0._wp) then + c = 100._wp*sgm_eps + else + c = sqrt(c) + end if + end if + end subroutine s_compute_speed_of_sound +#endif + +#ifndef MFC_PRE_PROCESS + pure subroutine s_compute_fast_magnetosonic_speed(rho, c, B, norm, c_fast, h) +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_fast_magnetosonic_speed +#else + !$acc routine seq +#endif + + real(wp), intent(in) :: B(3), rho, c + real(wp), intent(in) :: h ! only used for relativity + real(wp), intent(out) :: c_fast + integer, intent(in) :: norm + + real(wp) :: B2, term, disc + + B2 = sum(B**2) + + if (.not. relativity) then + term = c**2 + B2/rho + disc = term**2 - 4*c**2*(B(norm)**2/rho) + else + ! Note: this is approximation for the non-relatisitic limit; accurate solution requires solving a quartic equation + term = (c**2*(B(norm)**2 + rho*h) + B2)/(rho*h + B2) + disc = term**2 - 4*c**2*B(norm)**2/(rho*h + B2) + end if + +#ifdef DEBUG + if (disc < 0._wp) then + print *, 'rho, c, Bx, By, Bz, h, term, disc:', rho, c, B(1), B(2), B(3), h, term, disc + call s_mpi_abort('Error: negative discriminant in s_compute_fast_magnetosonic_speed') + end if +#endif + + c_fast = sqrt(0.5_wp*(term + sqrt(disc))) + + end subroutine s_compute_fast_magnetosonic_speed +#endif + +#ifndef MFC_PRE_PROCESS + subroutine s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast_L, c_fast_R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, idx, idx_tau) + + ! Computes the wave speeds for the Riemann solver +#ifdef _CRAYFTN + !DIR$ INLINEALWAYS s_compute_wave_speed +#else + !$acc routine seq +#endif + + ! Input parameters + integer, intent(in) :: wave_speeds + integer, intent(in) :: idx, idx_tau + real(wp), intent(in) :: rho_L, rho_R + real(wp), dimension(:), intent(in) :: vel_L, vel_R, tau_e_L, tau_e_R + real(wp), intent(in) :: pres_L, pres_R, c_L, c_R + real(wp), intent(in) :: gamma_L, gamma_R, pi_inf_L, pi_inf_R + real(wp), intent(in) :: rho_avg, c_avg + real(wp), intent(in) :: c_fast_L, c_fast_R + real(wp), intent(in) :: G_L, G_R + + ! Local variables + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + + ! Output parameters + real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P + + if (wave_speeds == 1) then + if (elasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) + s_S = (pres_R - tau_e_R(idx_tau) - pres_L + & + tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & + rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & + rho_R*(s_R - vel_R(idx))) + else if (mhd) then + s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) + s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + else if (hypoelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + else if (hyperelasticity) then + s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + else + s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) + s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) + s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + end if + else if (wave_speeds == 2) then + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) + pres_SR = pres_SL + Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & + (pres_SL/pres_L - 1._wp)*pres_L/ & + ((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) + s_L = vel_L(idx) - c_L*Ms_L + s_R = vel_R(idx) + c_R*Ms_R + s_S = 5e-1_wp*((vel_L(idx) + vel_R(idx)) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! ! follows Einfeldt et al. + ! s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L) + s_P = max(0._wp, s_R) + +#ifdef DEBUG + ! Check for potential issues in wave speed calculation + if (s_R <= s_L) then + print *, 'WARNING: Wave speed issue detected in s_compute_wave_speed' + print *, 'Left wave speed >= Right wave speed:', s_L, s_R + print *, 'Input velocities :', vel_L(idx), vel_R(idx) + print *, 'Sound speeds:', c_L, c_R + print *, 'Densities:', rho_L, rho_R + print *, 'Pressures:', pres_L, pres_R + print *, 'Wave speeds method:', wave_speeds + if (elasticity .or. hypoelasticity .or. hyperelasticity) then + print *, 'Shear moduli:', G_L, G_R + end if + call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') + end if +#endif + end subroutine s_compute_wave_speed +#endif + +end module m_variables_conversion \ No newline at end of file diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 25daa005e..17b64a00b 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1,3719 +1,3892 @@ -!> -!! @file m_riemann_solvers.f90 -!! @brief Contains module m_riemann_solvers - -!> @brief This module features a database of approximate and exact Riemann -!! problem solvers for the Navier-Stokes system of equations, which -!! is supplemented by appropriate advection equations that are used -!! to capture the material interfaces. The closure of the system is -!! achieved by the stiffened gas equation of state and any required -!! mixture relations. Surface tension effects are accounted for and -!! are modeled by means of a volume force acting across the diffuse -!! material interface region. The implementation details of viscous -!! and capillary effects, into the Riemann solvers, may be found in -!! Perigaud and Saurel (2005). Note that both effects are available -!! only in the volume fraction model. At this time, the approximate -!! and exact Riemann solvers that are listed below are available: -!! 1) Harten-Lax-van Leer (HLL) -!! 2) Harten-Lax-van Leer-Contact (HLLC) -!! 3) Exact -!! 4) Harten-Lax-van Leer Discontinuities (HLLD) - for MHD only - -#:include 'case.fpp' -#:include 'macros.fpp' -#:include 'inline_riemann.fpp' - -module m_riemann_solvers - - use m_derived_types !< Definitions of the derived types - - use m_global_parameters !< Definitions of the global parameters - - use m_mpi_proxy !< Message passing interface (MPI) module proxy - - use m_variables_conversion !< State variables type conversion procedures - - use m_bubbles !< To get the bubble wall pressure function - - use m_bubbles_EE - - use m_surface_tension !< To get the capilary fluxes - - use m_chemistry - - use m_thermochem, only: & - gas_constant, get_mixture_molecular_weight, & - get_mixture_specific_heat_cv_mass, get_mixture_energy_mass, & - get_species_specific_heats_r, get_species_enthalpies_rt, & - get_mixture_specific_heat_cp_mass - - implicit none - - private; public :: s_initialize_riemann_solvers_module, & - s_riemann_solver, & - s_hll_riemann_solver, & - s_hllc_riemann_solver, & - s_hlld_riemann_solver, & - s_finalize_riemann_solvers_module - - !> The cell-boundary values of the fluxes (src - source) that are computed - !! through the chosen Riemann problem solver, and the direct evaluation of - !! source terms, by using the left and right states given in qK_prim_rs_vf, - !! dqK_prim_ds_vf where ds = dx, dy or dz. - !> @{ - - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf - !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & - !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) - !> @} - - !> The cell-boundary values of the geometrical source flux that are computed - !! through the chosen Riemann problem solver by using the left and right - !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. - !> @{ - - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< - !$acc declare create( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) - !> @} - - ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as - ! part of Riemann problem solution and is used to evaluate the source flux. - - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf - !$acc declare create(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) - - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf - !$acc declare create(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) - - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf - !$acc declare create(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) - - !> @name Indical bounds in the s1-, s2- and s3-directions - !> @{ - type(int_bounds_info) :: is1, is2, is3 - type(int_bounds_info) :: isx, isy, isz - !> @} - - !$acc declare create(is1, is2, is3, isx, isy, isz) - - real(wp), allocatable, dimension(:) :: Gs - !$acc declare create(Gs) - - real(wp), allocatable, dimension(:, :) :: Res - !$acc declare create(Res) - -contains - - !> Dispatch to the subroutines that are utilized to compute the - !! Riemann problem solution. For additional information please reference: - !! 1) s_hll_riemann_solver - !! 2) s_hllc_riemann_solver - !! 3) s_exact_riemann_solver - !! 4) s_hlld_riemann_solver - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf - - type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(INOUT) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz - - #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4)] - if (riemann_solver == ${NUM}$) then - call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - end if - #:endfor - - end subroutine s_riemann_solver - - !> Dispatch to the subroutines that are utilized to compute - !! the viscous source fluxes for either Cartesian or cylindrical geometries. - !! For more information please refer to: - !! 1) s_compute_cartesian_viscous_source_flux - !! 2) s_compute_cylindrical_viscous_source_flux - subroutine s_compute_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - type(scalar_field), & - dimension(num_vels), & - intent(IN) :: velL_vf, velR_vf, & - dvelL_dx_vf, dvelR_dx_vf, & - dvelL_dy_vf, dvelR_dy_vf, & - dvelL_dz_vf, dvelR_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_src_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz - - if (grid_geometry == 3) then - call s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - else - call s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - end if - end subroutine s_compute_viscous_source_flux - - subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp) :: rho_L, rho_R - real(wp), dimension(num_vels) :: vel_L, vel_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R - real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi - real(wp) :: T_L, T_R - real(wp) :: Y_L, Y_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp) :: G_L, G_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp), dimension(3) :: xi_field_L, xi_field_R - - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_M, xi_P - - real(wp) :: ptilde_L, ptilde_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR - real(wp) :: alpha_L_sum, alpha_R_sum - real(wp) :: zcoef, pcorr !< low Mach number correction - - type(riemann_states) :: c_fast, pres_mag, vel - type(riemann_states_vec3) :: B - - type(riemann_states) :: Ga ! Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm ! Conservative momentum variables - - integer :: i, j, k, l, q !< Generic loop iterators - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - call s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - - if (norm_dir == ${NORM_DIR}$) then - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & - !$acc alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, & - !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, Ys_L, Ys_R, & - !$acc xi_field_L, xi_field_R, & - !$acc Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, & - !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & - !$acc c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, & - !$acc pcorr, zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - !$acc loop seq - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - !$acc loop seq - do i = 1, num_vels - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_vels - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 2) - end if - end if - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - pres_mag%L = 0._wp - pres_mag%R = 0._wp - - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) - alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) - alpha_L_sum = alpha_L_sum + alpha_L(i) - end do - - alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) - - !$acc loop seq - do i = 1, num_fluids - alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) - alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) - alpha_R_sum = alpha_R_sum + alpha_R(i) - end do - - alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & - + Re_L(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - elseif (mhd) then - if (relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - !acc loop seq - do i = 1, 3 - b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L - b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R - end do - - B2%L = sum(B%L**2._wp) - B2%R = sum(B%R**2._wp) - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - !acc loop seq - do i = 1, 3 - cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) - cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) - end do - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (.not. relativity) then - pres_mag%L = 0.5_wp*sum(B%L**2._wp) - pres_mag%R = 0.5_wp*sum(B%R**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - end if - else - E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! elastic energy update - if (hypoelasticity) then - G_L = 0._wp; G_R = 0._wp - - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - - if (cont_damage) then - G_L = G_L*max((1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) - G_R = G_R*max((1._wp - qR_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) - end if - - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! Elastic contribution to energy if G large enough - !TODO take out if statement if stable without - if ((G_L > 1000) .and. (G_R > 1000)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Double for shear stresses - if (any(strxb - 1 + i == shear_indices)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - ! elastic energy update - !if ( hyperelasticity ) then - ! G_L = 0._wp - ! G_R = 0._wp - ! - ! !$acc loop seq - ! do i = 1, num_fluids - ! G_L = G_L + alpha_L(i)*Gs(i) - ! G_R = G_R + alpha_R(i)*Gs(i) - ! end do - ! ! Elastic contribution to energy if G large enough - ! if ((G_L > 1e-3_wp) .and. (G_R > 1e-3_wp)) then - ! E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - ! E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - ! !$acc loop seq - ! do i = 1, b_size-1 - ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - ! tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! end do - ! !$acc loop seq - ! do i = 1, b_size-1 - ! tau_e_L(i) = 0_wp - ! tau_e_R(i) = 0_wp - ! end do - ! !$acc loop seq - ! do i = 1, num_dims - ! xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - ! end do - ! end if - !end if - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_sum_Yi_Phi, c_avg) - - if (mhd) then - call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) - call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) - end if - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & - + (5e-1_wp - sign(5e-1_wp, s_L)) & - *(5e-1_wp + sign(5e-1_wp, s_R)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_R)) & - + (5e-1_wp - sign(5e-1_wp, s_L)) & - *(5e-1_wp + sign(5e-1_wp, s_R)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! Mass - if (.not. relativity) then - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(alpha_rho_L(i) & - - alpha_rho_R(i))) & - /(s_M - s_P) - end do - elseif (relativity) then - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(Ga%L*alpha_rho_L(i) & - - Ga%R*alpha_rho_R(i))) & - /(s_M - s_P) - end do - end if - - ! Momentum and Energy fluxes - if (mhd) then - if (.not. relativity) then - ! Flux of rho*v_x in the ${XYZ}$ direction - ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - !acc loop seq - do i = 1, 3 - flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - - B%L(i)*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & - /(s_M - s_P) - end do - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - - elseif (relativity) then - do i = 1, 3 - ! Flux of m_x in the ${XYZ}$ direction - ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & - - b4%L(i)/Ga%L*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & - /(s_M - s_P) - end do - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - end if - elseif (bubbles_euler) then - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - ! energy flux - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R & - - tau_e_R(dir_idx_tau(i))) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L & - - tau_e_L(dir_idx_tau(i))) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) - end do - ! energy flux - !acc loop seq - do i = 1, num_dims - flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) - flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - ! energy flux - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - end if - - ! Elastic Stresses - if (hypoelasticity) then - do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *tau_e_R(i)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *tau_e_L(i)) & - + s_M*s_P*(rho_L*tau_e_L(i) & - - rho_R*tau_e_R(i))) & - /(s_M - s_P) - end do - end if - - ! Advection - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (qL_prim_rs${XYZ}$_vf(j, k, l, i) & - - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & - *s_M*s_P/(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & - /(s_M - s_P) - end do - - ! Xi field - !if ( hyperelasticity ) then - ! do i = 1, num_dims - ! flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - ! (s_M*rho_R*vel_R(dir_idx(1))*xi_field_R(i) & - ! - s_P*rho_L*vel_L(dir_idx(1))*xi_field_L(i) & - ! + s_M*s_P*(rho_L*xi_field_L(i) & - ! - rho_R*xi_field_R(i))) & - ! /(s_M - s_P) - ! end do - !end if - - ! Div(U)? - !$acc loop seq - do i = 1, num_vels - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - (xi_M*(rho_L*vel_L(dir_idx(i))* & - (s_L - vel_L(dir_idx(1))) - & - pres_L*dir_flg(dir_idx(i))) - & - xi_P*(rho_R*vel_R(dir_idx(i))* & - (s_R - vel_R(dir_idx(1))) - & - pres_R*dir_flg(dir_idx(i)))) & - /(xi_M*rho_L*(s_L - vel_L(dir_idx(1))) - & - xi_P*rho_R*(s_R - vel_R(dir_idx(1)))) - end do - - if (bubbles_euler) then - ! From HLLC: Kills mass transport @ bubble gas density - if (num_fluids > 1) then - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp - end if - end if - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - - flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & - - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & - /(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - - if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 - ! B_z flux = v_x * B_z - v_z * Bx0 - !acc loop seq - do i = 0, 1 - flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & - + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) - end do - else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - !$acc loop seq - do i = 0, 2 - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & - s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) - end do - end if - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp - end if - - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & - - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - end if - - if (cyl_coord .and. hypoelasticity) then - ! += tau_sigmasigma using HLL - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & - (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & - /(s_M - s_P) - - !$acc loop seq - do i = strxb, strxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - end if - #:endif - end do - end do - end do - end if - - #:endfor - - if (viscous) then - if (weno_Re_flux) then - - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - end if - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - end subroutine s_hll_riemann_solver - - !> This procedure is the implementation of the Harten, Lax, - !! van Leer, and contact (HLLC) approximate Riemann solver, - !! see Toro (1999) and Johnsen (2007). The viscous and the - !! surface tension effects have been included by modifying - !! the exact Riemann solver of Perigaud and Saurel (2005). - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp) :: rho_L, rho_R - real(wp), dimension(num_dims) :: vel_L, vel_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps - real(wp) :: T_L, T_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: Y_L, Y_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(2) :: Re_L, Re_R - - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_L, xi_R !< Left and right wave speeds functions - real(wp) :: xi_M, xi_P - real(wp) :: xi_MP, xi_PP - - real(wp) :: nbub_L, nbub_R - real(wp), dimension(nb) :: R0_L, R0_R - real(wp), dimension(nb) :: V0_L, V0_R - real(wp), dimension(nb) :: P0_L, P0_R - real(wp), dimension(nb) :: pbw_L, pbw_R - real(wp) :: ptilde_L, ptilde_R - - real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom - - real(wp) :: PbwR3Lbar, Pbwr3Rbar - real(wp) :: R3Lbar, R3Rbar - real(wp) :: R3V2Lbar, R3V2Rbar - - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp), dimension(num_dims) :: xi_field_L, xi_field_R - real(wp) :: G_L, G_R - - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star - real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R - real(wp) :: flux_ene_e - real(wp) :: zcoef, pcorr !< low Mach number correction - - integer :: i, j, k, l, q !< Generic loop iterators - integer :: idx1, idxi - type(riemann_states) :: c_fast, vel - - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - - call s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 - - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - - if (norm_dir == ${NORM_DIR}$) then - - ! 6-EQUATION MODEL WITH HLLC - if (model_eqns == 3) then - !ME3 - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(vel_L, vel_R, vel_K_Star, Re_L, Re_R, rho_avg, h_avg, gamma_avg, & - !$acc s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R, Ys_L, Ys_R, Xs_L, Xs_R, & - !$acc Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & - !$acc tau_e_L, tau_e_R, G_L, G_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, & - !$acc zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - idx1 = dir_idx(1) - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, advxb + i - 1) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, advxb + i - 1) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_L(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if - end if - end do - else if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - end if - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(idx1))/(s_L - s_S) - xi_R = (s_R - vel_R(idx1))/(s_R - s_S) - - ! goes with numerical star velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(0.5_wp, s_S)) - xi_P = (5e-1_wp - sign(0.5_wp, s_S)) - - ! goes with the numerical velocity in x/y/z directions - ! xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) - xi_MP = -min(0._wp, sign(1._wp, s_L)) - xi_PP = max(0._wp, sign(1._wp, s_R)) - - E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & - xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) - p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & - xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) - - rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + & - xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) - - vel_K_Star = vel_L(idx1)*(1_wp - xi_MP) + xi_MP*vel_R(idx1) + & - xi_MP*xi_PP*(s_S - vel_R(idx1)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING FLUXES - ! MASS FLUX. - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*(vel_L(idx1) + s_M*(xi_L - 1._wp)) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = rho_Star*vel_K_Star* & - (dir_flg(idxi)*vel_K_Star + (1_wp - dir_flg(idxi))*(xi_M*vel_L(idxi) + xi_P*vel_R(idxi))) + dir_flg(idxi)*p_Star & - + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr - end do - - ! ENERGY FLUX. - ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0_wp; - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - & - xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & - s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & - xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & - s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e - end if - - ! VOLUME FRACTION FLUX. - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*s_S + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S - end do - - ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & - xi_M*(vel_L(idxi) + dir_flg(idxi)*(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(idxi))) + & - xi_P*(vel_R(idxi) + dir_flg(idxi)*(s_S*(xi_PP*(xi_R - 1) + 1) - vel_R(idxi))) - end do - - ! INTERNAL ENERGIES ADVECTION FLUX. - ! K-th pressure and velocity in preparation for the internal energy flux - !$acc loop seq - do i = 1, num_fluids - p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1_wp + gammas(i)))* & - xi_L**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_L) + pres_L) + & - xi_P*(xi_PP*((pres_R + pi_infs(i)/(1_wp + gammas(i)))* & - xi_R**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_R) + pres_R) - - flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & - ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1))* & - (gammas(i)*p_K_Star + pi_infs(i)) + & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1))* & - qvs(i))*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) - end do - end if - - ! REFERENCE MAP FLUX. - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(idx1)*xi_field_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & - - rho_R*vel_R(idx1)*xi_field_R(i)) - end do - end if - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rs${XYZ}$_vf(j, k, l, c_idx) = & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S - end if - - ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() - end do - end do - end do - - elseif (model_eqns == 4) then - !ME4 - !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & - !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, nbub_L, nbub_R, ptilde_L, ptilde_R) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - !$acc loop seq - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - !$acc loop seq - do i = 1, num_dims - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - end do - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - !$acc loop seq - do i = 1, num_fluids - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) - xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*alpha_rho_L(i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*alpha_rho_R(i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_L) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_R) - end do - - if (bubbles_euler) then - ! Put p_tilde in - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + & - xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & - + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) - end do - end if - - flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp - - !$acc loop seq - do i = alf_idx, alf_idx !only advect the void fraction - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Source for volume fraction advection equation - !$acc loop seq - do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) - - ! Add advection flux for bubble variables - if (bubbles_euler) then - !$acc loop seq - do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - end if - - ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() - end do - end do - end do - !$acc end parallel loop - - elseif (model_eqns == 2 .and. bubbles_euler) then - !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & - !$acc rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms, Re_L, Re_R, pcorr, zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - ! Retain this in the refactor - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - else - rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) - gamma_R = gammas(1) - pi_inf_R = pi_infs(1) - qv_R = qvs(1) - end if - - if (viscous) then - if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_L(i) - Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_R(i) - end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - end if - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - if (avg_state == 2) then - !$acc loop seq - do i = 1, nb - R0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, rs(i)) - R0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, rs(i)) - - V0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, vs(i)) - V0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, vs(i)) - if (.not. polytropic .and. .not. qbmm) then - P0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, ps(i)) - P0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, ps(i)) - end if - end do - - if (.not. qbmm) then - if (adv_n) then - nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, n_idx) - nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, n_idx) - else - nbub_L_denom = 0._wp - nbub_R_denom = 0._wp - !$acc loop seq - do i = 1, nb - nbub_L_denom = nbub_L_denom + (R0_L(i)**3._wp)*weight(i) - nbub_R_denom = nbub_R_denom + (R0_R(i)**3._wp)*weight(i) - end do - nbub_L = (3._wp/(4._wp*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom - nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom - end if - else - !nb stored in 0th moment of first R0 bin in variable conversion module - nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) - nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, bubxb) - end if - - !$acc loop seq - do i = 1, nb - if (.not. qbmm) then - if (polytropic) then - pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0._wp) - pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0._wp) - else - pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), P0_L(i)) - pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), P0_R(i)) - end if - end if - end do - - if (qbmm) then - PbwR3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 4) - PbwR3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 4) - - R3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 1) - R3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 1) - - R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) - R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) - else - - PbwR3Lbar = 0._wp - PbwR3Rbar = 0._wp - - R3Lbar = 0._wp - R3Rbar = 0._wp - - R3V2Lbar = 0._wp - R3V2Rbar = 0._wp - - !$acc loop seq - do i = 1, nb - PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) - PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) - - R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) - R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) - - R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) - R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) - end do - end if - - if (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then - ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L - else - ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & - rho_L*R3V2Lbar/R3Lbar) - end if - - if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then - ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*pres_R - else - ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & - rho_R*R3V2Rbar/R3Rbar) - end if - - if ((ptilde_L /= ptilde_L) .or. (ptilde_R /= ptilde_R)) then - end if - - rho_avg = 5e-1_wp*(rho_L + rho_R) - H_avg = 5e-1_wp*(H_L + H_R) - gamma_avg = 5e-1_wp*(gamma_L + gamma_R) - vel_avg_rms = 0._wp - - !$acc loop seq - do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (5e-1_wp*(vel_L(i) + vel_R(i)))**2._wp - end do - - end if - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) - xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - if (bubbles_euler .and. (num_fluids > 1)) then - ! Kill mass transport @ gas density - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp - end if - - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - - ! Include p_tilde - - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr - end do - - ! Energy flux. - ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - xi_M*(vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + & - s_M*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + (pres_L - ptilde_L)/ & - (s_L - vel_L(dir_idx(1))))) - E_L)) & - + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) + & - s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + (pres_R - ptilde_R)/ & - (s_R - vel_R(dir_idx(1))))) - E_R)) & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! Volume fraction flux - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Source for volume fraction advection equation - !$acc loop seq - do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - xi_M*(vel_L(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_P*(xi_R - 1._wp)) - - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0._wp - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) - - ! Add advection flux for bubble variables - !$acc loop seq - do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - if (qbmm) then - flux_rs${XYZ}$_vf(j, k, l, bubxb) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end if - - if (adv_n) then - flux_rs${XYZ}$_vf(j, k, l, n_idx) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end if - - ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() - end do - end do - end do - !$acc end parallel loop - else - ! 5-EQUATION MODEL WITH HLLC - !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & - !$acc rho_avg, h_avg, gamma_avg, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & - !$acc vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & - !$acc tau_e_L, tau_e_R, xi_field_L, xi_field_R, & - !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2) copyin(is1,is2,is3) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - !idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - ! Change this by splitting it into the cases - ! present in the bubbles_euler - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) then - Re_L(i) = 0._wp - Re_R(i) = 0._wp - end if - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_L(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - c_sum_Yi_Phi = 0.0_wp - !$acc loop seq - do i = chemxb, chemxe - Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - else - E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY - if (hypoelasticity .or. hyperelasticity) then - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if - end if - end do - else if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - end if - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_sum_Yi_Phi, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(idx1))/(s_L - s_S) - xi_R = (s_R - vel_R(idx1))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING THE HLLC FLUXES - ! MASS FLUX. - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idxi) + & - s_M*(xi_L*(dir_flg(idxi)*s_S + & - (1._wp - dir_flg(idxi))* & - vel_L(idxi)) - vel_L(idxi))) + & - dir_flg(idxi)*(pres_L)) & - + xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idxi) + & - s_P*(xi_R*(dir_flg(idxi)*s_S + & - (1._wp - dir_flg(idxi))* & - vel_R(idxi)) - vel_R(idxi))) + & - dir_flg(idxi)*(pres_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr - end do - - ! ENERGY FLUX. - ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - xi_M*(vel_L(idx1)*(E_L + pres_L) + & - s_M*(xi_L*(E_L + (s_S - vel_L(idx1))* & - (rho_L*s_S + pres_L/ & - (s_L - vel_L(idx1)))) - E_L)) & - + xi_P*(vel_R(idx1)*(E_R + pres_R) + & - s_P*(xi_R*(E_R + (s_S - vel_R(idx1))* & - (rho_R*s_S + pres_R/ & - (s_R - vel_R(idx1)))) - E_R)) & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0_wp - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - & - xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & - s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & - xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & - s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e - end if - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) - end do - end if - - ! VOLUME FRACTION FLUX. - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! VOLUME FRACTION SOURCE FLUX. - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & - xi_M*(vel_L(idxi) + & - dir_flg(idxi)* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(idxi) + & - dir_flg(idxi)* & - s_P*(xi_R - 1._wp)) - end do - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rs${XYZ}$_vf(j, k, l, c_idx) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end if - - ! REFERENCE MAP FLUX. - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(idx1)*xi_field_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & - - rho_R*vel_R(idx1)*xi_field_R(i)) - end do - end if - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - - flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*rho_L*Y_L*(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*rho_R*Y_R*(vel_R(idx1) + s_P*(xi_R - 1._wp)) - flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp - end do - end if - - ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() - end do - end do - end do - !$acc end parallel loop - end if - end if - #:endfor - ! Computing HLLC flux and source flux for Euler system of equations - - if (viscous) then - if (weno_Re_flux) then - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - end if - end if - - if (surface_tension) then - call s_compute_capilary_source_flux( & - q_prim_vf, & - vel_src_rsx_vf, & - vel_src_rsy_vf, & - vel_src_rsz_vf, & - flux_src_vf, & - norm_dir, isx, isy, isz) - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux - ! end contains - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions - - end subroutine s_hllc_riemann_solver - - !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: - !! 1 entropy wave, 2 Alfvén waves, 2 fast magnetosonic waves. - subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables: - real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R - type(riemann_states_vec3) :: vel - type(riemann_states) :: rho, pres, E, H_no_mag - type(riemann_states) :: gamma, pi_inf, qv - type(riemann_states) :: vel_rms - - type(riemann_states_vec3) :: B - type(riemann_states) :: c, c_fast, pres_mag - - ! HLLD speeds and intermediate state variables: - real(wp) :: s_L, s_R, s_M, s_starL, s_starR - real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR - - real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR - real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) - ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction - ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction - - real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx - real(wp) :: vL_star, vR_star, wL_star, wR_star - real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double - - integer :: i, j, k, l - - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & - norm_dir, ix, iy, iz) - - call s_initialize_riemann_solver( & - q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (norm_dir == ${NORM_DIR}$) then - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, & - !$acc rho, pres, E, H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, & - !$acc U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - ! (1) Extract the left/right primitive states - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic - do i = 1, num_vels - vel%L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - vel%R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + dir_idx(i)) - end do - - vel_rms%L = sum(vel%L**2._wp) - vel_rms%R = sum(vel%R**2._wp) - - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres%L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres%R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1) - B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1) - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1) - end if - end if - - ! Sum properties of all fluid components - rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp - rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp - !$acc loop seq - do i = 1, num_fluids - rho%L = rho%L + alpha_rho_L(i) - gamma%L = gamma%L + alpha_L(i)*gammas(i) - pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) - qv%L = qv%L + alpha_rho_L(i)*qvs(i) - - rho%R = rho%R + alpha_rho_R(i) - gamma%R = gamma%R + alpha_R(i)*gammas(i) - pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) - qv%R = qv%R + alpha_rho_R(i)*qvs(i) - end do - - pres_mag%L = 0.5_wp*sum(B%L**2._wp) - pres_mag%R = 0.5_wp*sum(B%R**2._wp) - E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L - E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy - H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L - H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - - ! (2) Compute fast wave speeds - call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, 0._wp, c%L) - call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, 0._wp, c%R) - call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) - call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) - - ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] - s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) - s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) - - pTot_L = pres%L + pres_mag%L - pTot_R = pres%R + pres_mag%R - - s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - & - (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/ & - ((s_R - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) - - ! (4) Compute star state variables - rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) - rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) - p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) - E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) - E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - - ! (5) Compute left/right state vectors and fluxes - call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & - U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) - call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & - U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) - - ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - denom_ds = sqrt_rhoL_star + sqrt_rhoR_star - sign_Bx = sign(1._wp, B%L(1)) - v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds - w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds - By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds - Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star - wL_star)*sign_Bx)/denom_ds - - E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx - E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx - E_double = 0.5_wp*(E_doubleL + E_doubleR) - - U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - - ! (7) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - - ! (8) Choose HLLD flux based on wave-speed regions - if (0.0_wp <= s_L) then - F_hlld = F_L - else if (0.0_wp <= s_starL) then - F_hlld = F_L + s_L*(U_starL - U_L) - else if (0.0_wp <= s_M) then - F_hlld = F_starL + s_starL*(U_doubleL - U_starL) - else if (0.0_wp <= s_starR) then - F_hlld = F_starR + s_starR*(U_doubleR - U_starR) - else if (0.0_wp <= s_R) then - F_hlld = F_R + s_R*(U_starR - U_R) - else - F_hlld = F_R - end if - - ! (9) Reorder and write temporary variables to the flux array - ! Mass - flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component - ! Momentum - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(2)) = F_hlld(3) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(3)) = F_hlld(4) - ! Magnetic field - if (n == 0) then - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = F_hlld(6) - else - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) = F_hlld(6) - end if - ! Energy - flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) - ! Partial fraction - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp - end do - end do - end do - !$acc end parallel loop - end if - #:endfor - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho - U(2) = rho*vel(1) - U(3) = rho*vel(2) - U(4) = rho*vel(3) - U(5) = B(2) - U(6) = B(3) - U(7) = E - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3) - F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star - U_star(2) = rho_star*s_M - U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3) - U_star(5) = B(2) - U_star(6) = B(3) - U_star(7) = E_star - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables - ! end contains - end subroutine s_hlld_riemann_solver - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. - subroutine s_initialize_riemann_solvers_module - - ! Allocating the variables that will be utilized to formulate the - ! left, right, and average states of the Riemann problem, as well - ! the Riemann problem solution - integer :: i, j - - @:ALLOCATE(Gs(1:num_fluids)) - - do i = 1, num_fluids - Gs(i) = fluid_pp(i)%G - end do - !$acc update device(Gs) - - if (viscous) then - @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) - end if - - if (viscous) then - do i = 1, 2 - do j = 1, Re_size(i) - Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) - end do - end do - !$acc update device(Res, Re_idx, Re_size) - end if - - !$acc enter data copyin(is1, is2, is3, isx, isy, isz) - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = m; is2%end = n; is3%end = p - - @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - if (qbmm) then - @:ALLOCATE(mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - if (n == 0) return - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = n; is2%end = m; is3%end = p - - @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - - if (qbmm) then - @:ALLOCATE(mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - if (p == 0) return - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = p; is2%end = n; is3%end = m - - @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - - if (qbmm) then - @:ALLOCATE(mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - end subroutine s_initialize_riemann_solvers_module - - !> The purpose of this subroutine is to populate the buffers - !! of the left and right Riemann states variables, depending - !! on the boundary conditions. - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - subroutine s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf - - type(scalar_field), & - allocatable, dimension(:), & - target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf - type(scalar_field), & - dimension(:), & - pointer :: dqL_prim_d_vf, dqR_prim_d_vf - - integer :: end_val, bc_beg, bc_end - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l !< Generic loop iterator - - if (norm_dir == 1) then - is1 = ix; is2 = iy; is3 = iz - dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - bc_beg = bc_x%beg; bc_end = bc_x%end - end_val = m - qL_prim_rs_vf => qL_prim_rsx_vf - qR_prim_rs_vf => qR_prim_rsx_vf - dqL_prim_d_vf => dqL_prim_dx_vf - dqR_prim_d_vf => dqR_prim_dx_vf - else if (norm_dir == 2) then - is1 = iy; is2 = ix; is3 = iz - dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) - bc_beg = bc_y%beg; bc_end = bc_y%end - end_val = n - qL_prim_rs_vf => qL_prim_rsy_vf - qR_prim_rs_vf => qR_prim_rsy_vf - dqL_prim_d_vf => dqL_prim_dy_vf - dqR_prim_d_vf => dqR_prim_dy_vf - else - is1 = iz; is2 = iy; is3 = ix - dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) - bc_beg = bc_z%beg; bc_end = bc_z%end - end_val = p - qL_prim_rs_vf => qL_prim_rsz_vf - qR_prim_rs_vf => qR_prim_rsz_vf - dqL_prim_d_vf => dqL_prim_dz_vf - dqR_prim_d_vf => dqR_prim_dz_vf - end if - - !$acc update device(is1, is2, is3) - - if (elasticity) then - if (norm_dir == 1) then - dir_idx_tau = (/1, 2, 4/) - else if (norm_dir == 2) then - dir_idx_tau = (/3, 2, 5/) - else - dir_idx_tau = (/6, 4, 5/) - end if - end if - - isx = ix; isy = iy; isz = iz - !$acc update device(isx, isy, isz) ! for stuff in the same module - !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - - ! Population of Buffers in x/y/z-direction - if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) - end do - end do - end do - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) - if (n > 0) then - dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) - end if - end if - else if (norm_dir == 2) then - dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) - dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) - end if - else - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) - end if - end do - end do - end do - end if - end if - - if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) - end do - end do - end do - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) - if (n > 0) then - dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) - end if - end if - else if (norm_dir == 2) then - dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) - dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) - end if - else - dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) - dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) - dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) - end if - end do - end do - end do - end if - end if - - end subroutine s_populate_riemann_states_variables_buffers - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures needed to configure the chosen Riemann - !! solver algorithm. - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l ! Generic loop iterators - ! Reshaping Inputted Data in x-direction - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = 0._wp - else if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - if (norm_dir == 1) then - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - else if (norm_dir == 2) then - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - else if (norm_dir == 3) then - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end if - end do - end do - end do - end do - end if - - end subroutine s_initialize_riemann_solver - - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. - !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives - !! and cylindrical geometric factors, then updates `flux_src_vf`. - !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). - !! @param[in] velL_vf Left boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary $\partial v_i/\partial x$ (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary $\partial v_i/\partial y$ (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary $\partial v_i/\partial z$ (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary $\partial v_i/\partial x$ (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary $\partial v_i/\partial y$ (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary $\partial v_i/\partial z$ (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). - !! @param[in] ix Global X-direction loop bounds (int_bounds_info). - !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if - if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp - end if - end do - - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select - - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff - if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff - end if - - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp - - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select - - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if - - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b - - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if - - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cylindrical_viscous_source_flux - - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - !! @param[in] ix X-direction loop bounds (int_bounds_info). - !! @param[in] iy Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Z-direction loop bounds (int_bounds_info). - subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - end do - - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) - end do - - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) - end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) - end do - end if - - if (shear_stress) then - current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do - end if - - if (bulk_stress) then - current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do - end if - - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cartesian_viscous_source_flux - - !> @brief Calculates shear stress tensor components. - !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear - !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). - !! @param[in] Re_shear Shear Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq - - implicit none - - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out - - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. - - tau_shear_out = 0.0_wp - - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear - end if - end do - end do - - end subroutine s_calculate_shear_stress_tensor - - !> @brief Calculates bulk stress tensor components (diagonal only). - !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. - !! @param[in] Re_bulk Bulk Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq - - implicit none - - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. - - tau_bulk_out = 0.0_wp - - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do - - end subroutine s_calculate_bulk_stress_tensor - - !> Deallocation and/or disassociation procedures that are - !! needed to finalize the selected Riemann problem solver - !! @param flux_vf Intercell fluxes - !! @param flux_src_vf Intercell source fluxes - !! @param flux_gsrc_vf Intercell geometric source fluxes - !! @param norm_dir Dimensional splitting coordinate direction - !! @param ix Index bounds in first coordinate direction - !! @param iy Index bounds in second coordinate direction - !! @param iz Index bounds in third coordinate direction - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l !< Generic loop iterators - - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if - end do - end do - end do - end do - - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - if (grid_geometry == 3) then - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end if - end do - end do - end do - end do - - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - end if - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end if - end do - end do - end do - end do - end if - - end subroutine s_finalize_riemann_solver - - !> Module deallocation and/or disassociation procedures - subroutine s_finalize_riemann_solvers_module - - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if - - if (n == 0) return - - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if - - if (p == 0) return - - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if - - end subroutine s_finalize_riemann_solvers_module - -end module m_riemann_solvers +!> +!! @file m_riemann_solvers.f90 +!! @brief Contains module m_riemann_solvers + +!> @brief This module features a database of approximate and exact Riemann +!! problem solvers for the Navier-Stokes system of equations, which +!! is supplemented by appropriate advection equations that are used +!! to capture the material interfaces. The closure of the system is +!! achieved by the stiffened gas equation of state and any required +!! mixture relations. Surface tension effects are accounted for and +!! are modeled by means of a volume force acting across the diffuse +!! material interface region. The implementation details of viscous +!! and capillary effects, into the Riemann solvers, may be found in +!! Perigaud and Saurel (2005). Note that both effects are available +!! only in the volume fraction model. At this time, the approximate +!! and exact Riemann solvers that are listed below are available: +!! 1) Harten-Lax-van Leer (HLL) +!! 2) Harten-Lax-van Leer-Contact (HLLC) +!! 3) Exact +!! 4) Harten-Lax-van Leer Discontinuities (HLLD) - for MHD only + +#:include 'case.fpp' +#:include 'macros.fpp' +#:include 'inline_riemann.fpp' + +module m_riemann_solvers + + use m_derived_types !< Definitions of the derived types + + use m_global_parameters !< Definitions of the global parameters + + use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_variables_conversion !< State variables type conversion procedures + + use m_bubbles !< To get the bubble wall pressure function + + use m_bubbles_EE + + use m_surface_tension !< To get the capilary fluxes + + use m_chemistry + + use m_thermochem, only: & + gas_constant, get_mixture_molecular_weight, & + get_mixture_specific_heat_cv_mass, get_mixture_energy_mass, & + get_species_specific_heats_r, get_species_enthalpies_rt, & + get_mixture_specific_heat_cp_mass + + implicit none + + private; public :: s_initialize_riemann_solvers_module, & + s_riemann_solver, & + s_hll_riemann_solver, & + s_hllc_riemann_solver, & + s_hlld_riemann_solver, & + s_finalize_riemann_solvers_module + + !> The cell-boundary values of the fluxes (src - source) that are computed + !! through the chosen Riemann problem solver, and the direct evaluation of + !! source terms, by using the left and right states given in qK_prim_rs_vf, + !! dqK_prim_ds_vf where ds = dx, dy or dz. + !> @{ + + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf + !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & + !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) + !> @} + + !> The cell-boundary values of the geometrical source flux that are computed + !! through the chosen Riemann problem solver by using the left and right + !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. + !> @{ + + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< + !$acc declare create( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) + !> @} + + ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as + ! part of Riemann problem solution and is used to evaluate the source flux. + + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf + !$acc declare create(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) + + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf + !$acc declare create(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) + + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf + !$acc declare create(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) + + !> @name Indical bounds in the s1-, s2- and s3-directions + !> @{ + type(int_bounds_info) :: is1, is2, is3 + type(int_bounds_info) :: isx, isy, isz + !> @} + + !$acc declare create(is1, is2, is3, isx, isy, isz) + + real(wp), allocatable, dimension(:) :: Gs + !$acc declare create(Gs) + + real(wp), allocatable, dimension(:, :) :: Res + !$acc declare create(Res) + +contains + + !> Dispatch to the subroutines that are utilized to compute the + !! Riemann problem solution. For additional information please reference: + !! 1) s_hll_riemann_solver + !! 2) s_hllc_riemann_solver + !! 3) s_exact_riemann_solver + !! 4) s_hlld_riemann_solver + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf + + type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(INOUT) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), & + dimension(sys_size), & + intent(INOUT) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(IN) :: norm_dir + + type(int_bounds_info), intent(IN) :: ix, iy, iz + + #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4)] + if (riemann_solver == ${NUM}$) then + call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + end if + #:endfor + + end subroutine s_riemann_solver + + !> Dispatch to the subroutines that are utilized to compute + !! the viscous source fluxes for either Cartesian or cylindrical geometries. + !! For more information please refer to: + !! 1) s_compute_cartesian_viscous_source_flux + !! 2) s_compute_cylindrical_viscous_source_flux + pure subroutine s_compute_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + + type(scalar_field), & + dimension(num_vels), & + intent(IN) :: velL_vf, velR_vf, & + dvelL_dx_vf, dvelR_dx_vf, & + dvelL_dy_vf, dvelR_dy_vf, & + dvelL_dz_vf, dvelR_dz_vf + + type(scalar_field), & + dimension(sys_size), & + intent(INOUT) :: flux_src_vf + + integer, intent(IN) :: norm_dir + + type(int_bounds_info), intent(IN) :: ix, iy, iz + + if (grid_geometry == 3) then + call s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + else + call s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + end if + end subroutine s_compute_viscous_source_flux + + subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_vels) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R + real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi + real(wp) :: T_L, T_R + real(wp) :: Y_L, Y_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp), dimension(3) :: xi_field_L, xi_field_R + + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_M, xi_P + + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum + real(wp) :: zcoef, pcorr !< low Mach number correction + + type(riemann_states) :: c_fast, pres_mag + type(riemann_states_vec3) :: B + + type(riemann_states) :: Ga ! Gamma (Lorentz factor) + type(riemann_states) :: vdotB, B2 + type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm ! Conservative momentum variables + + integer :: i, j, k, l, q !< Generic loop iterators + + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + call s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + + if (norm_dir == ${NORM_DIR}$) then + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & + !$acc alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, & + !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, Ys_L, Ys_R, & + !$acc xi_field_L, xi_field_R, & + !$acc Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, & + !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & + !$acc c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, & + !$acc pcorr, zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + !$acc loop seq + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + !$acc loop seq + do i = 1, num_vels + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + !$acc loop seq + do i = 1, num_vels + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables + B%L(1) = Bx0 + B%R(1) = Bx0 + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + else ! 2D/3D: Bx, By, Bz as variables + B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) + B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 2) + end if + end if + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + pres_mag%L = 0._wp + pres_mag%R = 0._wp + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) + alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) + alpha_L_sum = alpha_L_sum + alpha_L(i) + end do + + alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) + + !$acc loop seq + do i = 1, num_fluids + alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) + alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) + alpha_R_sum = alpha_R_sum + alpha_R(i) + end do + + alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + + Re_L(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + elseif (mhd) then + if (relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + !acc loop seq + do i = 1, 3 + b4%L(i) = B%L(i)/Ga%L + Ga%L*vel_L(i)*vdotB%L + b4%R(i) = B%R(i)/Ga%R + Ga%R*vel_R(i)*vdotB%R + end do + + B2%L = sum(B%L**2._wp) + B2%R = sum(B%R**2._wp) + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + !acc loop seq + do i = 1, 3 + cm%L(i) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(i) - vdotB%L*B%L(i) + cm%R(i) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(i) - vdotB%R*B%R(i) + end do + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (.not. relativity) then + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + end if + else + E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! elastic energy update + if (hypoelasticity) then + G_L = 0._wp; G_R = 0._wp + + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + + if (cont_damage) then + G_L = G_L*max((1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) + G_R = G_R*max((1._wp - qR_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) + end if + + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + ! Elastic contribution to energy if G large enough + !TODO take out if statement if stable without + if ((G_L > 1000) .and. (G_R > 1000)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Double for shear stresses + if (any(strxb - 1 + i == shear_indices)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + ! elastic energy update + !if ( hyperelasticity ) then + ! G_L = 0._wp + ! G_R = 0._wp + ! + ! !$acc loop seq + ! do i = 1, num_fluids + ! G_L = G_L + alpha_L(i)*Gs(i) + ! G_R = G_R + alpha_R(i)*Gs(i) + ! end do + ! ! Elastic contribution to energy if G large enough + ! if ((G_L > 1e-3_wp) .and. (G_R > 1e-3_wp)) then + ! E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + ! E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + ! !$acc loop seq + ! do i = 1, b_size-1 + ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + ! tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + ! end do + ! !$acc loop seq + ! do i = 1, b_size-1 + ! tau_e_L(i) = 0_wp + ! tau_e_R(i) = 0_wp + ! end do + ! !$acc loop seq + ! do i = 1, num_dims + ! xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + ! end do + ! end if + !end if + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, c_sum_Yi_Phi, c_avg) + + if (mhd) then + call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) + call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) + end if + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + + (5e-1_wp - sign(5e-1_wp, s_L)) & + *(5e-1_wp + sign(5e-1_wp, s_R)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_R)) & + + (5e-1_wp - sign(5e-1_wp, s_L)) & + *(5e-1_wp + sign(5e-1_wp, s_R)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! Mass + if (.not. relativity) then + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*alpha_rho_R(i)*vel_R(norm_dir) & + - s_P*alpha_rho_L(i)*vel_L(norm_dir) & + + s_M*s_P*(alpha_rho_L(i) & + - alpha_rho_R(i))) & + /(s_M - s_P) + end do + elseif (relativity) then + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & + - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & + + s_M*s_P*(Ga%L*alpha_rho_L(i) & + - Ga%R*alpha_rho_R(i))) & + /(s_M - s_P) + end do + end if + + ! Momentum + if (mhd .and. (.not. relativity)) then + ! Flux of rho*v_x in the ${XYZ}$ direction + ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & + - B%R(1)*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & + - B%L(1)*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & + /(s_M - s_P) + ! Flux of rho*v_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & + - B%R(2)*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & + - B%L(2)*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & + /(s_M - s_P) + ! Flux of rho*v_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & + - B%R(3)*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & + - B%L(3)*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! Flux of m_x in the ${XYZ}$ direction + ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(cm%R(1)*vel_R(norm_dir) & + - b4%R(1)/Ga%R*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(1)*vel_L(norm_dir) & + - b4%L(1)/Ga%L*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(1) - cm%R(1))) & + /(s_M - s_P) + ! Flux of m_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(cm%R(2)*vel_R(norm_dir) & + - b4%R(2)/Ga%R*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(2)*vel_L(norm_dir) & + - b4%L(2)/Ga%L*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(2) - cm%R(2))) & + /(s_M - s_P) + ! Flux of m_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(cm%R(3)*vel_R(norm_dir) & + - b4%R(3)/Ga%R*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(3)*vel_L(norm_dir) & + - b4%L(3)/Ga%L*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(3) - cm%R(3))) & + /(s_M - s_P) + elseif (bubbles_euler) then + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + else if (hypoelasticity) then + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_R & + - tau_e_R(dir_idx_tau(i))) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_L & + - tau_e_L(dir_idx_tau(i))) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) + end do + else + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_R) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_L) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + end if + + ! Energy + if (mhd .and. (.not. relativity)) then + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux + ! Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (bubbles_euler) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + else if (hypoelasticity) then + !TODO: simplify this so it's not split into 3 + if (num_dims == 1) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (num_dims == 2) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & + - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & + - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (num_dims == 3) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & + - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & + - (tau_e_R(dir_idx_tau(3))*vel_R(dir_idx(3)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & + - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2))) & + - (tau_e_L(dir_idx_tau(3))*vel_L(dir_idx(3)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + end if + else + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + end if + + ! Elastic Stresses + if (hypoelasticity) then + do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *tau_e_R(i)) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *tau_e_L(i)) & + + s_M*s_P*(rho_L*tau_e_L(i) & + - rho_R*tau_e_R(i))) & + /(s_M - s_P) + end do + end if + + ! Advection + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (qL_prim_rs${XYZ}$_vf(j, k, l, i) & + - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & + *s_M*s_P/(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & + /(s_M - s_P) + end do + + ! Xi field + !if ( hyperelasticity ) then + ! do i = 1, num_dims + ! flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + ! (s_M*rho_R*vel_R(dir_idx(1))*xi_field_R(i) & + ! - s_P*rho_L*vel_L(dir_idx(1))*xi_field_L(i) & + ! + s_M*s_P*(rho_L*xi_field_L(i) & + ! - rho_R*xi_field_R(i))) & + ! /(s_M - s_P) + ! end do + !end if + + ! Div(U)? + !$acc loop seq + do i = 1, num_vels + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & + (xi_M*(rho_L*vel_L(dir_idx(i))* & + (s_L - vel_L(dir_idx(1))) - & + pres_L*dir_flg(dir_idx(i))) - & + xi_P*(rho_R*vel_R(dir_idx(i))* & + (s_R - vel_R(dir_idx(1))) - & + pres_R*dir_flg(dir_idx(i)))) & + /(xi_M*rho_L*(s_L - vel_L(dir_idx(1))) - & + xi_P*rho_R*(s_R - vel_R(dir_idx(1)))) + end do + + if (bubbles_euler) then + ! From HLLC: Kills mass transport @ bubble gas density + if (num_fluids > 1) then + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp + end if + end if + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + + flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & + - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & + /(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + + if (mhd) then + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 + flux_rsx_vf(j, k, l, B_idx%beg) = (s_M*(vel_R(1)*B%R(2) - vel_R(2)*Bx0) & + - s_P*(vel_L(1)*B%L(2) - vel_L(2)*Bx0) + s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) + + ! B_z flux = v_x * B_z - v_z * Bx0 + flux_rsx_vf(j, k, l, B_idx%beg + 1) = (s_M*(vel_R(1)*B%R(3) - vel_R(3)*Bx0) & + - s_P*(vel_L(1)*B%L(3) - vel_L(3)*Bx0) + s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) + + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = (1 - dir_flg(1))*( & + s_M*(vel_R(dir_idx(1))*B%R(1) - vel_R(1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(1) - vel_L(1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(1) - B%R(1)))/(s_M - s_P) + + ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = (1 - dir_flg(2))*( & + s_M*(vel_R(dir_idx(1))*B%R(2) - vel_R(2)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(2) - vel_L(2)*B%L(norm_dir)) + & + s_M*s_P*(B%L(2) - B%R(2)))/(s_M - s_P) + + ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) = (1 - dir_flg(3))*( & + s_M*(vel_R(dir_idx(1))*B%R(3) - vel_R(3)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(3) - vel_L(3)*B%L(norm_dir)) + & + s_M*s_P*(B%L(3) - B%R(3)))/(s_M - s_P) + + end if + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp + end if + + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & + - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + end if + + if (cyl_coord .and. hypoelasticity) then + ! += tau_sigmasigma using HLL + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & + (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & + /(s_M - s_P) + + !$acc loop seq + do i = strxb, strxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + end if + #:endif + + end do + end do + end do + end if + + #:endfor + + if (viscous) then + if (weno_Re_flux) then + + call s_compute_viscous_source_flux( & + qL_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + qR_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux( & + q_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + q_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + end if + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + end subroutine s_hll_riemann_solver + + !> This procedure is the implementation of the Harten, Lax, + !! van Leer, and contact (HLLC) approximate Riemann solver, + !! see Toro (1999) and Johnsen (2007). The viscous and the + !! surface tension effects have been included by modifying + !! the exact Riemann solver of Perigaud and Saurel (2005). + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_dims) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps + real(wp) :: T_L, T_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: Y_L, Y_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(2) :: Re_L, Re_R + + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_L, xi_R !< Left and right wave speeds functions + real(wp) :: xi_M, xi_P + real(wp) :: xi_MP, xi_PP + + real(wp) :: nbub_L, nbub_R + real(wp), dimension(nb) :: R0_L, R0_R + real(wp), dimension(nb) :: V0_L, V0_R + real(wp), dimension(nb) :: P0_L, P0_R + real(wp), dimension(nb) :: pbw_L, pbw_R + real(wp) :: ptilde_L, ptilde_R + + real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom + + real(wp) :: PbwR3Lbar, Pbwr3Rbar + real(wp) :: R3Lbar, R3Rbar + real(wp) :: R3V2Lbar, R3V2Rbar + + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp), dimension(num_dims) :: xi_field_L, xi_field_R + real(wp) :: G_L, G_R + + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + real(wp) :: flux_ene_e + real(wp) :: zcoef, pcorr !< low Mach number correction + + integer :: i, j, k, l, q !< Generic loop iterators + integer :: idx1, idxi + type(riemann_states) :: c_fast, vel + + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions + + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + + call s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 + + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + + if (norm_dir == ${NORM_DIR}$) then + + ! 6-EQUATION MODEL WITH HLLC + if (model_eqns == 3) then + !ME3 + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(vel_L, vel_R, vel_K_Star, Re_L, Re_R, rho_avg, h_avg, gamma_avg, & + !$acc s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R, Ys_L, Ys_R, Xs_L, Xs_R, & + !$acc Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & + !$acc tau_e_L, tau_e_R, G_L, G_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, & + !$acc zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + idx1 = dir_idx(1) + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, advxb + i - 1) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, advxb + i - 1) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_L(i) + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) then + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if + end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + end if + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + ! COMPUTING THE DIRECT WAVE SPEEDS + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(idx1))/(s_L - s_S) + xi_R = (s_R - vel_R(idx1))/(s_R - s_S) + + ! goes with numerical star velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(0.5_wp, s_S)) + xi_P = (5e-1_wp - sign(0.5_wp, s_S)) + + ! goes with the numerical velocity in x/y/z directions + ! xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) + xi_MP = -min(0._wp, sign(1._wp, s_L)) + xi_PP = max(0._wp, sign(1._wp, s_R)) + + E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & + (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & + xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & + (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) + p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & + xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) + + rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + & + xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) + + vel_K_Star = vel_L(idx1)*(1_wp - xi_MP) + xi_MP*vel_R(idx1) + & + xi_MP*xi_PP*(s_S - vel_R(idx1)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING FLUXES + ! MASS FLUX. + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*(vel_L(idx1) + s_M*(xi_L - 1._wp)) + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! MOMENTUM FLUX. + ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = rho_Star*vel_K_Star* & + (dir_flg(idxi)*vel_K_Star + (1_wp - dir_flg(idxi))*(xi_M*vel_L(idxi) + xi_P*vel_R(idxi))) + dir_flg(idxi)*p_Star & + + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr + end do + + ! ENERGY FLUX. + ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0_wp; + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + ! MOMENTUM ELASTIC FLUX. + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & + - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - & + xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & + xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & + s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e + end if + + ! VOLUME FRACTION FLUX. + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*s_S + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S + end do + + ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & + xi_M*(vel_L(idxi) + dir_flg(idxi)*(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(idxi))) + & + xi_P*(vel_R(idxi) + dir_flg(idxi)*(s_S*(xi_PP*(xi_R - 1) + 1) - vel_R(idxi))) + end do + + ! INTERNAL ENERGIES ADVECTION FLUX. + ! K-th pressure and velocity in preparation for the internal energy flux + !$acc loop seq + do i = 1, num_fluids + p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1_wp + gammas(i)))* & + xi_L**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_L) + pres_L) + & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1_wp + gammas(i)))* & + xi_R**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_R) + pres_R) + + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1))* & + (gammas(i)*p_K_Star + pi_infs(i)) + & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1))* & + qvs(i))*vel_K_Star & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) + end do + end if + + ! REFERENCE MAP FLUX. + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + - rho_L*vel_L(idx1)*xi_field_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & + - rho_R*vel_R(idx1)*xi_field_R(i)) + end do + end if + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rs${XYZ}$_vf(j, k, l, c_idx) = & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + + end do + end do + end do + + elseif (model_eqns == 4) then + !ME4 + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & + !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, nbub_L, nbub_R, ptilde_L, ptilde_R) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + !$acc loop seq + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + !$acc loop seq + do i = 1, num_dims + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) + xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*alpha_rho_L(i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*alpha_rho_R(i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Momentum flux. + ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(i)) + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & + dir_flg(dir_idx(i))*pres_L) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(i)) + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & + dir_flg(dir_idx(i))*pres_R) + end do + + if (bubbles_euler) then + ! Put p_tilde in + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + & + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & + + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) + end do + end if + + flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp + + !$acc loop seq + do i = alf_idx, alf_idx !only advect the void fraction + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Source for volume fraction advection equation + !$acc loop seq + do i = 1, num_dims + + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) + + ! Add advection flux for bubble variables + if (bubbles_euler) then + !$acc loop seq + do i = bubxb, bubxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end do + end do + end do + !$acc end parallel loop + + elseif (model_eqns == 2 .and. bubbles_euler) then + !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & + !$acc rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms, Re_L, Re_R, pcorr, zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + ! Retain this in the refactor + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else if (num_fluids > 2) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) + rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) + gamma_R = gammas(1) + pi_inf_R = pi_infs(1) + qv_R = qvs(1) + end if + + if (viscous) then + if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_L(i) + Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_R(i) + end do + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + end if + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + if (avg_state == 2) then + !$acc loop seq + do i = 1, nb + R0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, rs(i)) + R0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, rs(i)) + + V0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, vs(i)) + V0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, vs(i)) + if (.not. polytropic .and. .not. qbmm) then + P0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, ps(i)) + P0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, ps(i)) + end if + end do + + if (.not. qbmm) then + if (adv_n) then + nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, n_idx) + nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, n_idx) + else + nbub_L_denom = 0._wp + nbub_R_denom = 0._wp + !$acc loop seq + do i = 1, nb + nbub_L_denom = nbub_L_denom + (R0_L(i)**3._wp)*weight(i) + nbub_R_denom = nbub_R_denom + (R0_R(i)**3._wp)*weight(i) + end do + nbub_L = (3._wp/(4._wp*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom + nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom + end if + else + !nb stored in 0th moment of first R0 bin in variable conversion module + nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) + nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, bubxb) + end if + + !$acc loop seq + do i = 1, nb + if (.not. qbmm) then + if (polytropic) then + pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0._wp) + pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0._wp) + else + pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), P0_L(i)) + pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), P0_R(i)) + end if + end if + end do + + if (qbmm) then + PbwR3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 4) + PbwR3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 4) + + R3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 1) + R3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 1) + + R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) + R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) + else + + PbwR3Lbar = 0._wp + PbwR3Rbar = 0._wp + + R3Lbar = 0._wp + R3Rbar = 0._wp + + R3V2Lbar = 0._wp + R3V2Rbar = 0._wp + + !$acc loop seq + do i = 1, nb + PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) + PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) + + R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) + R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) + + R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) + R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) + end do + end if + + if (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L + else + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & + rho_L*R3V2Lbar/R3Lbar) + end if + + if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*pres_R + else + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & + rho_R*R3V2Rbar/R3Rbar) + end if + + if ((ptilde_L /= ptilde_L) .or. (ptilde_R /= ptilde_R)) then + end if + + rho_avg = 5e-1_wp*(rho_L + rho_R) + H_avg = 5e-1_wp*(H_L + H_R) + gamma_avg = 5e-1_wp*(gamma_L + gamma_R) + vel_avg_rms = 0._wp + + !$acc loop seq + do i = 1, num_dims + vel_avg_rms = vel_avg_rms + (5e-1_wp*(vel_L(i) + vel_R(i)))**2._wp + end do + + end if + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) + xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + if (bubbles_euler .and. (num_fluids > 1)) then + ! Kill mass transport @ gas density + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp + end if + + ! Momentum flux. + ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + + ! Include p_tilde + + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(i)) + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(i)) + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & + + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + end do + + ! Energy flux. + ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + xi_M*(vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + & + s_M*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & + (rho_L*s_S + (pres_L - ptilde_L)/ & + (s_L - vel_L(dir_idx(1))))) - E_L)) & + + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) + & + s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & + (rho_R*s_S + (pres_R - ptilde_R)/ & + (s_R - vel_R(dir_idx(1))))) - E_R)) & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! Volume fraction flux + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Source for volume fraction advection equation + !$acc loop seq + do i = 1, num_dims + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & + xi_M*(vel_L(dir_idx(i)) + & + dir_flg(dir_idx(i))* & + s_M*(xi_L - 1._wp)) & + + xi_P*(vel_R(dir_idx(i)) + & + dir_flg(dir_idx(i))* & + s_P*(xi_R - 1._wp)) + + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0._wp + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) + + ! Add advection flux for bubble variables + !$acc loop seq + do i = bubxb, bubxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + if (qbmm) then + flux_rs${XYZ}$_vf(j, k, l, bubxb) = & + xi_M*nbub_L & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end if + + if (adv_n) then + flux_rs${XYZ}$_vf(j, k, l, n_idx) = & + xi_M*nbub_L & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif + end do + end do + end do + !$acc end parallel loop + else + ! 5-EQUATION MODEL WITH HLLC + !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & + !$acc rho_avg, h_avg, gamma_avg, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & + !$acc vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & + !$acc tau_e_L, tau_e_R, xi_field_L, xi_field_R, & + !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2) copyin(is1,is2,is3) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + !idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + ! Change this by splitting it into the cases + ! present in the bubbles_euler + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + if (Re_size(i) > 0) then + Re_L(i) = 0._wp + Re_R(i) = 0._wp + end if + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_L(i) + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + c_sum_Yi_Phi = 0.0_wp + !$acc loop seq + do i = chemxb, chemxe + Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + else + E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC/HYPERELASTIC ENERGY + if (hypoelasticity .or. hyperelasticity) then + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if + end if + end do + else if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + end if + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, c_sum_Yi_Phi, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(idx1))/(s_L - s_S) + xi_R = (s_R - vel_R(idx1))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING THE HLLC FLUXES + ! MASS FLUX. + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! MOMENTUM FLUX. + ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idxi) + & + s_M*(xi_L*(dir_flg(idxi)*s_S + & + (1._wp - dir_flg(idxi))* & + vel_L(idxi)) - vel_L(idxi))) + & + dir_flg(idxi)*(pres_L)) & + + xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idxi) + & + s_P*(xi_R*(dir_flg(idxi)*s_S + & + (1._wp - dir_flg(idxi))* & + vel_R(idxi)) - vel_R(idxi))) + & + dir_flg(idxi)*(pres_R)) & + + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr + end do + + ! ENERGY FLUX. + ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + xi_M*(vel_L(idx1)*(E_L + pres_L) + & + s_M*(xi_L*(E_L + (s_S - vel_L(idx1))* & + (rho_L*s_S + pres_L/ & + (s_L - vel_L(idx1)))) - E_L)) & + + xi_P*(vel_R(idx1)*(E_R + pres_R) + & + s_P*(xi_R*(E_R + (s_S - vel_R(idx1))* & + (rho_R*s_S + pres_R/ & + (s_R - vel_R(idx1)))) - E_R)) & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0_wp + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + ! MOMENTUM ELASTIC FLUX. + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & + - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - & + xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & + xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & + s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e + end if + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) + end do + end if + + ! VOLUME FRACTION FLUX. + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! VOLUME FRACTION SOURCE FLUX. + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & + xi_M*(vel_L(idxi) + & + dir_flg(idxi)* & + s_M*(xi_L - 1._wp)) & + + xi_P*(vel_R(idxi) + & + dir_flg(idxi)* & + s_P*(xi_R - 1._wp)) + end do + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rs${XYZ}$_vf(j, k, l, c_idx) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end if + + ! REFERENCE MAP FLUX. + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + - rho_L*vel_L(idx1)*xi_field_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & + - rho_R*vel_R(idx1)*xi_field_R(i)) + end do + end if + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*rho_L*Y_L*(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*rho_R*Y_R*(vel_R(idx1) + s_P*(xi_R - 1._wp)) + flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp + end do + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & + xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + + xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + - xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif + + end do + end do + end do + !$acc end parallel loop + end if + end if + #:endfor + ! Computing HLLC flux and source flux for Euler system of equations + + if (viscous) then + if (weno_Re_flux) then + call s_compute_viscous_source_flux( & + qL_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + qR_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux( & + q_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + q_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + end if + end if + + if (surface_tension) then + call s_compute_capilary_source_flux( & + q_prim_vf, & + vel_src_rsx_vf, & + vel_src_rsy_vf, & + vel_src_rsz_vf, & + flux_src_vf, & + norm_dir, isx, isy, isz) + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + end subroutine s_hllc_riemann_solver + + !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: + !! 1 entropy wave, 2 Alfvén waves, 2 fast magnetosonic waves. + subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables: + real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R + type(riemann_states_vec3) :: vel + type(riemann_states) :: rho, pres, E, H_no_mag + type(riemann_states) :: gamma, pi_inf, qv + type(riemann_states) :: vel_rms + + type(riemann_states_vec3) :: B + type(riemann_states) :: c, c_fast, pres_mag + + ! HLLD speeds and intermediate state variables: + real(wp) :: s_L, s_R, s_M, s_starL, s_starR + real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR + + real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR + real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld + ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) + ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction + ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction + + real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx + real(wp) :: vL_star, vR_star, wL_star, wR_star + real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double + + integer :: i, j, k, l + + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & + norm_dir, ix, iy, iz) + + call s_initialize_riemann_solver( & + q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (norm_dir == ${NORM_DIR}$) then + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, & + !$acc rho, pres, E, H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, & + !$acc U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + ! (1) Extract the left/right primitive states + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic + do i = 1, num_vels + vel%L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + vel%R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + dir_idx(i)) + end do + + vel_rms%L = sum(vel%L**2._wp) + vel_rms%R = sum(vel%R**2._wp) + + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + pres%L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres%R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated + B%L(1) = Bx0 + B%R(1) = Bx0 + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + else ! 2D/3D: Bx, By, Bz as variables + B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1) + B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1) + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1) + end if + end if + + ! Sum properties of all fluid components + rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp + rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp + !$acc loop seq + do i = 1, num_fluids + rho%L = rho%L + alpha_rho_L(i) + gamma%L = gamma%L + alpha_L(i)*gammas(i) + pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) + qv%L = qv%L + alpha_rho_L(i)*qvs(i) + + rho%R = rho%R + alpha_rho_R(i) + gamma%R = gamma%R + alpha_R(i)*gammas(i) + pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) + qv%R = qv%R + alpha_rho_R(i)*qvs(i) + end do + + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L + E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy + H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L + H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + + ! (2) Compute fast wave speeds + call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, 0._wp, c%L) + call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, 0._wp, c%R) + call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) + call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) + + ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] + s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) + s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) + + pTot_L = pres%L + pres_mag%L + pTot_R = pres%R + pres_mag%R + + s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - & + (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/ & + ((s_R - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) + + ! (4) Compute star state variables + rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) + rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) + p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) + E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) + E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) + + ! (5) Compute left/right state vectors and fluxes + call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & + U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) + call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & + U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) + + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] + denom_ds = sqrt_rhoL_star + sqrt_rhoR_star + sign_Bx = sign(1._wp, B%L(1)) + v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds + w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds + By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds + Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star - wL_star)*sign_Bx)/denom_ds + + E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx + E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx + E_double = 0.5_wp*(E_doubleL + E_doubleR) + + U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions + if (0.0_wp <= s_L) then + F_hlld = F_L + else if (0.0_wp <= s_starL) then + F_hlld = F_L + s_L*(U_starL - U_L) + else if (0.0_wp <= s_M) then + F_hlld = F_starL + s_starL*(U_doubleL - U_starL) + else if (0.0_wp <= s_starR) then + F_hlld = F_starR + s_starR*(U_doubleR - U_starR) + else if (0.0_wp <= s_R) then + F_hlld = F_R + s_R*(U_starR - U_R) + else + F_hlld = F_R + end if + + ! (9) Reorder and write temporary variables to the flux array + ! Mass + flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component + ! Momentum + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(2)) = F_hlld(3) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(3)) = F_hlld(4) + ! Magnetic field + if (n == 0) then + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = F_hlld(5) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = F_hlld(6) + else + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) = F_hlld(5) + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) = F_hlld(6) + end if + ! Energy + flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) + ! Partial fraction + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp + end do + end do + end do + !$acc end parallel loop + end if + #:endfor + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + contains + function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) + implicit none + real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double + real(wp) :: U_double(7) + + U_double(1) = rho_star + U_double(2) = rho_star*s_M + U_double(3) = rho_star*v_double + U_double(4) = rho_star*w_double + U_double(5) = By_double + U_double(6) = Bz_double + U_double(7) = E_double + end function s_compute_U_double + + subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + real(wp), dimension(7), intent(out) :: F_star + ! Compute the base state vector + U(1) = rho + U(2) = rho*vel(1) + U(3) = rho*vel(2) + U(4) = rho*vel(3) + U(5) = B(2) + U(6) = B(3) + U(7) = E + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3) = U(2)*vel(2) - B(1)*B(2) + F(4) = U(2)*vel(3) - B(1)*B(3) + F(5) = vel(1)*B(2) - vel(2)*B(1) + F(6) = vel(1)*B(3) - vel(3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star state + U_star(1) = rho_star + U_star(2) = rho_star*s_M + U_star(3) = rho_star*vel(2) + U_star(4) = rho_star*vel(3) + U_star(5) = B(2) + U_star(6) = B(3) + U_star(7) = E_star + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables + ! end contains + end subroutine s_hlld_riemann_solver + + !> The computation of parameters, the allocation of memory, + !! the association of pointers and/or the execution of any + !! other procedures that are necessary to setup the module. + impure subroutine s_initialize_riemann_solvers_module + + ! Allocating the variables that will be utilized to formulate the + ! left, right, and average states of the Riemann problem, as well + ! the Riemann problem solution + integer :: i, j + + @:ALLOCATE(Gs(1:num_fluids)) + + do i = 1, num_fluids + Gs(i) = fluid_pp(i)%G + end do + !$acc update device(Gs) + + if (viscous) then + @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) + end if + + if (viscous) then + do i = 1, 2 + do j = 1, Re_size(i) + Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) + end do + end do + !$acc update device(Res, Re_idx, Re_size) + end if + + !$acc enter data copyin(is1, is2, is3, isx, isy, isz) + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = m; is2%end = n; is3%end = p + + @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + if (qbmm) then + @:ALLOCATE(mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + if (n == 0) return + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = n; is2%end = m; is3%end = p + + @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + + if (qbmm) then + @:ALLOCATE(mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + if (p == 0) return + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = p; is2%end = n; is3%end = m + + @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + + if (qbmm) then + @:ALLOCATE(mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + end subroutine s_initialize_riemann_solvers_module + + !> The purpose of this subroutine is to populate the buffers + !! of the left and right Riemann states variables, depending + !! on the boundary conditions. + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + subroutine s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf + + type(scalar_field), & + allocatable, dimension(:), & + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + integer :: i, j, k, l !< Generic loop iterator + + if (norm_dir == 1) then + is1 = ix; is2 = iy; is3 = iz + dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then + is1 = iy; is2 = ix; is3 = iz + dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf + else + is1 = iz; is2 = iy; is3 = ix + dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf + end if + + !$acc update device(is1, is2, is3) + + if (elasticity) then + if (norm_dir == 1) then + dir_idx_tau = (/1, 2, 4/) + else if (norm_dir == 2) then + dir_idx_tau = (/3, 2, 5/) + else + dir_idx_tau = (/6, 4, 5/) + end if + end if + + isx = ix; isy = iy; isz = iz + !$acc update device(isx, isy, isz) ! for stuff in the same module + !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules + + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) + end do + end do + end do + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if + end do + end do + end do + end if + end if + + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) + end do + end do + end do + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if + end do + end do + end do + end if + end if + + end subroutine s_populate_riemann_states_variables_buffers + + !> The computation of parameters, the allocation of memory, + !! the association of pointers and/or the execution of any + !! other procedures needed to configure the chosen Riemann + !! solver algorithm. + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + integer :: i, j, k, l ! Generic loop iterators + ! Reshaping Inputted Data in x-direction + + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if + end do + end do + end do + end do + end if + + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if + end do + end do + end do + end do + end if + + end subroutine s_initialize_riemann_solver + + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives + !! and cylindrical geometric factors, then updates `flux_src_vf`. + !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). + !! @param[in] velL_vf Left boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary $\partial v_i/\partial x$ (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary $\partial v_i/\partial y$ (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary $\partial v_i/\partial z$ (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary $\partial v_i/\partial x$ (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary $\partial v_i/\partial y$ (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary $\partial v_i/\partial z$ (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). + !! @param[in] ix Global X-direction loop bounds (int_bounds_info). + !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). + pure subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if + if (num_dims > 2) then + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp + end if + end do + + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + if (num_dims > 2) then + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + end if + + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp + + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s + + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + if (num_dims > 1) then + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + end if + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + end if + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select + + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + end do + end if + + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b + + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if + + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cylindrical_viscous_source_flux + + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !! Calculates averaged velocity gradients, gets Re and interface velocities, + !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !! @param[in] ix X-direction loop bounds (int_bounds_info). + !! @param[in] iy Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Z-direction loop bounds (int_bounds_info). + pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + end do + + divergence_v = 0.0_wp + do i_dim = 1, num_dims + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) + end do + + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if + + if (shear_stress) then + ! current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if + + if (bulk_stress) then + ! current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) + + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do + end if + + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cartesian_viscous_source_flux + + !> @brief Calculates shear stress tensor components. + !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear + !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). + !! @param[in] Re_shear Shear Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). + pure subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. + + tau_shear_out = 0.0_wp + + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do + end do + + end subroutine s_calculate_shear_stress_tensor + + !> @brief Calculates bulk stress tensor components (diagonal only). + !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. + !! @param[in] Re_bulk Bulk Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). + pure subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. + + tau_bulk_out = 0.0_wp + + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do + + end subroutine s_calculate_bulk_stress_tensor + + !> Deallocation and/or disassociation procedures that are + !! needed to finalize the selected Riemann problem solver + !! @param flux_vf Intercell fluxes + !! @param flux_src_vf Intercell source fluxes + !! @param flux_gsrc_vf Intercell geometric source fluxes + !! @param norm_dir Dimensional splitting coordinate direction + !! @param ix Index bounds in first coordinate direction + !! @param iy Index bounds in second coordinate direction + !! @param iz Index bounds in third coordinate direction + pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + integer :: i, j, k, l !< Generic loop iterators + + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if + end do + end do + end do + end do + + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(4) gang vector default(present) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if + end do + end do + end do + end do + + elseif (norm_dir == 1) then + !$acc parallel loop collapse(4) gang vector default(present) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do + end do + end do + end do + end if + + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) + end if + end do + end do + end do + end do + end if + + end subroutine s_finalize_riemann_solver + + !> Module deallocation and/or disassociation procedures + impure subroutine s_finalize_riemann_solvers_module + + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if + + if (n == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if + + if (p == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if + + end subroutine s_finalize_riemann_solvers_module + +end module m_riemann_solvers From 44f8f5d0bcc00e9e25e4ac1f3fb35bf57dcdace8 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Thu, 5 Jun 2025 03:36:00 -0400 Subject: [PATCH 41/58] fixed minor error --- src/common/m_variables_conversion.fpp | 39 +++------------------------ 1 file changed, 4 insertions(+), 35 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 905acd539..517d5b7ca 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1751,39 +1751,12 @@ contains real(wp), intent(out) :: s_L, s_R, s_S, s_M, s_P if (wave_speeds == 1) then -<<<<<<< HEAD - if (mhd) then - s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) - s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) - elseif (hypoelasticity .or. elasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) - else - s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) - s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) - end if - s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) - elseif (wave_speeds == 2) then -======= if (elasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + s_L = min(vel_L(idx) - sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(idx) - sqrt(c_R*c_R + & (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + s_R = max(vel_R(idx) + sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(idx) + sqrt(c_L*c_L + & (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) s_S = (pres_R - tau_e_R(idx_tau) - pres_L + & tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & @@ -1823,7 +1796,6 @@ contains /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) end if else if (wave_speeds == 2) then ->>>>>>> refactor-dev pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) pres_SR = pres_SL Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & @@ -1858,10 +1830,7 @@ contains call s_mpi_abort('Error: Invalid wave speeds in s_compute_wave_speed') end if #endif -<<<<<<< HEAD -======= ->>>>>>> refactor-dev end subroutine s_compute_wave_speed #endif From 174902b675d47093ebe2cdbfb0ecfae0a9beba9b Mon Sep 17 00:00:00 2001 From: mohdsaid497566 Date: Fri, 6 Jun 2025 00:15:11 -0400 Subject: [PATCH 42/58] working refactor --- src/simulation/m_riemann_solvers.fpp | 374 ++++++++++++++++++++++----- 1 file changed, 304 insertions(+), 70 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 9bc47ec2c..697190457 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -713,52 +713,75 @@ contains end do end if - ! Momentum and Energy fluxes - if (mhd) then - if (.not. relativity) then - ! Flux of rho*v_x in the ${XYZ}$ direction - ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - !acc loop seq - do i = 1, 3 - flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) & - - B%R(i)*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(i)*vel_L(norm_dir) & - - B%L(i)*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i))) & - /(s_M - s_P) - end do - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - - elseif (relativity) then - do i = 1, 3 - ! Flux of m_x in the ${XYZ}$ direction - ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + i) = & - (s_M*(cm%R(i)*vel_R(norm_dir) & - - b4%R(i)/Ga%R*B%R(norm_dir) & - + dir_flg(i)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(i)*vel_L(norm_dir) & - - b4%L(i)/Ga%L*B%L(norm_dir) & - + dir_flg(i)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(i) - cm%R(i))) & - /(s_M - s_P) - end do - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - end if + ! Momentum + if (mhd .and. (.not. relativity)) then + ! Flux of rho*v_x in the ${XYZ}$ direction + ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & + - B%R(1)*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & + - B%L(1)*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & + /(s_M - s_P) + ! Flux of rho*v_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & + - B%R(2)*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & + - B%L(2)*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & + /(s_M - s_P) + ! Flux of rho*v_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & + - B%R(3)*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & + - B%L(3)*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! Flux of m_x in the ${XYZ}$ direction + ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(cm%R(1)*vel_R(norm_dir) & + - b4%R(1)/Ga%R*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(1)*vel_L(norm_dir) & + - b4%L(1)/Ga%L*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(1) - cm%R(1))) & + /(s_M - s_P) + ! Flux of m_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(cm%R(2)*vel_R(norm_dir) & + - b4%R(2)/Ga%R*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(2)*vel_L(norm_dir) & + - b4%L(2)/Ga%L*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(2) - cm%R(2))) & + /(s_M - s_P) + ! Flux of m_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(cm%R(3)*vel_R(norm_dir) & + - b4%R(3)/Ga%R*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(3)*vel_L(norm_dir) & + - b4%L(3)/Ga%L*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(3) - cm%R(3))) & + /(s_M - s_P) elseif (bubbles_euler) then !$acc loop seq do i = 1, num_vels @@ -774,13 +797,6 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do - ! energy flux - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then !$acc loop seq do i = 1, num_vels @@ -797,17 +813,6 @@ contains - rho_R*vel_R(dir_idx(i)))) & /(s_M - s_P) end do - ! energy flux - !acc loop seq - do i = 1, num_dims - flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) - flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) else !$acc loop seq do i = 1, num_vels @@ -823,7 +828,65 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) end do - ! energy flux + end if + + ! Energy + if (mhd .and. (.not. relativity)) then + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux + ! Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (bubbles_euler) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + else if (hypoelasticity) then + !TODO: simplify this so it's not split into 3 + if (num_dims == 1) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (num_dims == 2) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & + - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & + - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (num_dims == 3) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & + - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & + - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & + - (tau_e_R(dir_idx_tau(3))*vel_R(dir_idx(3)))) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & + - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & + - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2))) & + - (tau_e_L(dir_idx_tau(3))*vel_L(dir_idx(3)))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + end if + else flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & @@ -831,7 +894,7 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp end if - + ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow @@ -1480,7 +1543,39 @@ contains end if ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif end do end do end do @@ -1652,7 +1747,52 @@ contains end if ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif end do end do end do @@ -2016,7 +2156,54 @@ contains end if ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif end do end do end do @@ -2413,7 +2600,54 @@ contains end if ! Geometrical source flux for cylindrical coordinates - call s_compute_cylindrical_geometry_source_flux() + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & + xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + + xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + - xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif end do end do end do From 60c7621f1c5e255a98a70331b5cd40cf43da5e9a Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Fri, 6 Jun 2025 02:00:24 -0400 Subject: [PATCH 43/58] fixed some loops --- src/simulation/m_riemann_solvers.fpp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 697190457..dd098ee5e 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3829,7 +3829,7 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end @@ -3849,7 +3849,7 @@ contains ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end @@ -3868,7 +3868,7 @@ contains end do elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) + !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end From c11ed1e95b10a2d263a422b2428859163e1f258c Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Fri, 6 Jun 2025 02:35:55 -0400 Subject: [PATCH 44/58] HLLD further refactored --- src/simulation/m_riemann_solvers.fpp | 86 ++++++++-------------------- 1 file changed, 23 insertions(+), 63 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index dd098ee5e..a350026e5 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2872,19 +2872,15 @@ contains ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic if (mhd) then if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1)] + B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1) - B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1) - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1) + B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -2936,9 +2932,9 @@ contains E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) ! (5) Compute left/right state vectors and fluxes - call s_compute_hlld_state_variables('L', rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & + call s_compute_hlld_state_variables(rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) - call s_compute_hlld_state_variables('R', rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & + call s_compute_hlld_state_variables(rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] @@ -2953,9 +2949,9 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL = s_compute_U_double(rhoL_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - U_doubleR = s_compute_U_double(rhoR_star, s_M, v_double, w_double, By_double, Bz_double, E_double) - + U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, E_double] + U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*w_double, rhoR_star*w_double, By_double, Bz_double, E_double] + ! (7) Compute the rotational (Alfvén) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) @@ -2979,16 +2975,12 @@ contains ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(2)) = F_hlld(3) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(3)) = F_hlld(4) + flux_rs${XYZ}$_vf(j, k, l, [contxe + dir_idx(1), contxe + dir_idx(2), contxe + dir_idx(3)]) = F_hlld([2, 3, 4]) ! Magnetic field if (n == 0) then - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = F_hlld(6) + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg, B_idx%beg + 1]) = F_hlld([5, 6]) else - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) = F_hlld(6) + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg + dir_idx(2) - 1, B_idx%beg + dir_idx(3) - 1]) = F_hlld([5, 6]) end if ! Energy flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) @@ -2997,7 +2989,6 @@ contains do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) end do - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp end do end do @@ -3010,55 +3001,24 @@ contains norm_dir, ix, iy, iz) contains - function s_compute_U_double(rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double) result(U_double) - implicit none - real(wp), intent(in) :: rho_star, s_M, v_double, w_double, By_double, Bz_double, E_double - real(wp) :: U_double(7) - - U_double(1) = rho_star - U_double(2) = rho_star*s_M - U_double(3) = rho_star*v_double - U_double(4) = rho_star*w_double - U_double(5) = By_double - U_double(6) = Bz_double - U_double(7) = E_double - end function s_compute_U_double - - subroutine s_compute_hlld_state_variables(side, rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + subroutine s_compute_hlld_state_variables(rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) implicit none ! Input parameters - character(len=1), intent(in) :: side ! dummy 'L' for left or 'R' for right real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E real(wp), dimension(:), intent(in) :: vel, B ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star + real(wp), dimension(7), intent(out) :: U, F, U_star, F_star real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - real(wp), dimension(7), intent(out) :: F_star - ! Compute the base state vector - U(1) = rho - U(2) = rho*vel(1) - U(3) = rho*vel(2) - U(4) = rho*vel(3) - U(5) = B(2) - U(6) = B(3) - U(7) = E + ! Compute the base/star state vector + U = [rho, rho*vel(1:3), B(2:3), E] + U_star = [rho_star, rho_star*s_M, rho_star*vel(2:3), B(2:3), E_star] ! Compute the flux vector F(1) = U(2) F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3) = U(2)*vel(2) - B(1)*B(2) - F(4) = U(2)*vel(3) - B(1)*B(3) - F(5) = vel(1)*B(2) - vel(2)*B(1) - F(6) = vel(1)*B(3) - vel(3)*B(1) + F(3:4) = U(2)*vel(2:3) - B(1)*B(2:3) + F(5:6) = vel(1)*B(2:3) - vel(2:3)*B(1) F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star state - U_star(1) = rho_star - U_star(2) = rho_star*s_M - U_star(3) = rho_star*vel(2) - U_star(4) = rho_star*vel(3) - U_star(5) = B(2) - U_star(6) = B(3) - U_star(7) = E_star ! Compute the star flux using HLL relation F_star = F + s_wave*(U_star - U) ! Compute additional parameters needed for double-star states From 5d4e6faa516d6dd5c481aed3550272121a832bbe Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Fri, 6 Jun 2025 04:09:23 -0400 Subject: [PATCH 45/58] HLLC refactored further --- src/simulation/m_riemann_solvers.fpp | 121 +++++++++------------------ 1 file changed, 39 insertions(+), 82 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index a350026e5..f7f3ac0ff 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1187,6 +1187,7 @@ contains integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi type(riemann_states) :: c_fast, vel + integer :: loop_end call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & @@ -1414,9 +1415,9 @@ contains xi_PP = max(0._wp, sign(1._wp, s_R)) E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & + (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) + (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) @@ -1588,6 +1589,13 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end + ! Initialize all variables + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; + !$acc loop seq do i = 1, contxe alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) @@ -1598,11 +1606,6 @@ contains do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - !$acc loop seq - do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2._wp vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do @@ -1611,35 +1614,19 @@ contains do i = 1, num_fluids alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - !$acc loop seq - do i = 1, num_fluids rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - end do - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - !$acc loop seq - do i = 1, num_fluids rho_R = rho_R + alpha_rho_R(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) qv_R = qv_R + alpha_rho_R(i)*qvs(i) end do + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R @@ -1701,18 +1688,13 @@ contains (1._wp - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*pres_R) - end do - - if (bubbles_euler) then - ! Put p_tilde in - !$acc loop seq - do i = 1, num_dims + if (bubbles_euler) then + ! Put p_tilde in flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + & - xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L)) & - + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) - end do - end if + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - & + dir_flg(dir_idx(i))*(xi_M*ptilde_L + xi_P*ptilde_R) + end if + end do flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp @@ -1805,14 +1787,19 @@ contains do k = is2%beg, is2%end do j = is1%beg, is1%end + ! Initialize all variables + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; + !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) end do - vel_L_rms = 0._wp; vel_R_rms = 0._wp - !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) @@ -1824,31 +1811,13 @@ contains pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp + loop_end = num_fluids + if (.not. mpp_lim .and. num_fluids > 2) loop_end = num_fluids - 1 ! Retain this in the refactor if (mpp_lim .and. (num_fluids > 2)) then !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 + do i = 1, loop_end rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) @@ -2221,15 +2190,17 @@ contains !idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + alpha_L_sum = 0._wp; alpha_R_sum = 0._wp + !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - !$acc loop seq - do i = 1, num_dims vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2._wp @@ -2239,19 +2210,6 @@ contains pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - ! Change this by splitting it into the cases ! present in the bubbles_euler if (mpp_lim) then @@ -2277,7 +2235,6 @@ contains gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) From 19b84f27e998ab9534c961e2c746a27e1c6412f5 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Sat, 7 Jun 2025 00:06:31 -0400 Subject: [PATCH 46/58] removed s_compute_cylindrical_geometry_source_flux --- src/simulation/m_riemann_solvers.fpp | 72 ---------------------------- 1 file changed, 72 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index f7f3ac0ff..7fa41b7aa 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2653,78 +2653,6 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - subroutine s_compute_cylindrical_geometry_source_flux() - !$acc routine seq - ! This subroutine computes the cylindrical geometry source fluxes - #:if (NORM_DIR == 2) - if (cyl_coord) then - if (model_eqns == 3) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - if (model_eqns == 3) then - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - else - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - end if - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end subroutine s_compute_cylindrical_geometry_source_flux - ! end contains ! Populating the buffers of the left and right Riemann problem ! states variables, based on the choice of boundary conditions From c3690db4489cf25c1b5ef07a27860fad2d0568e4 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Sat, 7 Jun 2025 00:36:49 -0400 Subject: [PATCH 47/58] small changes --- src/simulation/m_riemann_solvers.fpp | 53 ++++++++++++++-------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 7fa41b7aa..77aaa6996 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2885,35 +2885,34 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) - contains - subroutine s_compute_hlld_state_variables(rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star, F_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - ! Compute the base/star state vector - U = [rho, rho*vel(1:3), B(2:3), E] - U_star = [rho_star, rho_star*s_M, rho_star*vel(2:3), B(2:3), E_star] - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3:4) = U(2)*vel(2:3) - B(1)*B(2:3) - F(5:6) = vel(1)*B(2:3) - vel(2:3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables - ! end contains end subroutine s_hlld_riemann_solver + subroutine s_compute_hlld_state_variables(rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + implicit none + ! Input parameters + real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E + real(wp), dimension(:), intent(in) :: vel, B + ! Output parameters + real(wp), dimension(7), intent(out) :: U, F, U_star, F_star + real(wp), intent(out) :: sqrt_rho_star, v_star, w_star + ! Compute the base/star state vector + U = [rho, rho*vel(1:3), B(2:3), E] + U_star = [rho_star, rho_star*s_M, rho_star*vel(2:3), B(2:3), E_star] + ! Compute the flux vector + F(1) = U(2) + F(2) = U(2)*vel(1) - B(1)*B(1) + pTot + F(3:4) = U(2)*vel(2:3) - B(1)*B(2:3) + F(5:6) = vel(1)*B(2:3) - vel(2:3)*B(1) + F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) + ! Compute the star flux using HLL relation + F_star = F + s_wave*(U_star - U) + ! Compute additional parameters needed for double-star states + sqrt_rho_star = sqrt(rho_star) + v_star = vel(2) + w_star = vel(3) + end subroutine s_compute_hlld_state_variables + !> The computation of parameters, the allocation of memory, !! the association of pointers and/or the execution of any !! other procedures that are necessary to setup the module. From d8ff08924cf488e0ed5c088e85aceb60e495131f Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Sat, 7 Jun 2025 01:04:56 -0400 Subject: [PATCH 48/58] HLL small refactor --- src/simulation/m_riemann_solvers.fpp | 59 +++++++--------------------- 1 file changed, 14 insertions(+), 45 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 77aaa6996..12c976b20 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -284,7 +284,7 @@ contains type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L = 0._wp, flux_tau_R = 0._wp + real(wp) :: flux_tau_L, flux_tau_R integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -380,17 +380,13 @@ contains alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq do i = 1, num_vels vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_vels vel_L_rms = vel_L_rms + vel_L(i)**2._wp vel_R_rms = vel_R_rms + vel_R(i)**2._wp end do @@ -444,17 +440,12 @@ contains alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) alpha_L_sum = alpha_L_sum + alpha_L(i) - end do - - alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) - - !$acc loop seq - do i = 1, num_fluids alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) alpha_R_sum = alpha_R_sum + alpha_R(i) end do + alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) end if @@ -854,38 +845,16 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp else if (hypoelasticity) then - !TODO: simplify this so it's not split into 3 - if (num_dims == 1) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 2) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (num_dims == 3) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) & - - (tau_e_R(dir_idx_tau(1))*vel_R(dir_idx(1))) & - - (tau_e_R(dir_idx_tau(2))*vel_R(dir_idx(2))) & - - (tau_e_R(dir_idx_tau(3))*vel_R(dir_idx(3)))) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) & - - (tau_e_L(dir_idx_tau(1))*vel_L(dir_idx(1))) & - - (tau_e_L(dir_idx_tau(2))*vel_L(dir_idx(2))) & - - (tau_e_L(dir_idx_tau(3))*vel_L(dir_idx(3)))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - end if + flux_tau_L = 0._wp; flux_tau_R = 0._wp + !$acc loop seq + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & From e69c4efa3933b4305421b2b0ce3390275d0493c9 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Sat, 7 Jun 2025 01:11:13 -0400 Subject: [PATCH 49/58] prettifying --- src/common/m_variables_conversion.fpp | 46 +++++++++---------- src/simulation/m_riemann_solvers.fpp | 66 +++++++++++++-------------- 2 files changed, 55 insertions(+), 57 deletions(-) diff --git a/src/common/m_variables_conversion.fpp b/src/common/m_variables_conversion.fpp index 517d5b7ca..36fc36a94 100644 --- a/src/common/m_variables_conversion.fpp +++ b/src/common/m_variables_conversion.fpp @@ -1753,47 +1753,47 @@ contains if (wave_speeds == 1) then if (elasticity) then s_L = min(vel_L(idx) - sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(idx) - sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L), vel_R(idx) - sqrt(c_R*c_R + & + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R)) s_R = max(vel_R(idx) + sqrt(c_R*c_R + & - (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(idx) + sqrt(c_L*c_L + & - (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) + (((4_wp*G_R)/3_wp) + tau_e_R(idx_tau))/rho_R), vel_L(idx) + sqrt(c_L*c_L + & + (((4_wp*G_L)/3_wp) + tau_e_L(idx_tau))/rho_L)) s_S = (pres_R - tau_e_R(idx_tau) - pres_L + & - tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & - rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & - rho_R*(s_R - vel_R(idx))) + tau_e_L(idx_tau) + rho_L*vel_L(idx)*(s_L - vel_L(idx)) - & + rho_R*vel_R(idx)*(s_R - vel_R(idx)))/(rho_L*(s_L - vel_L(idx)) - & + rho_R*(s_R - vel_R(idx))) else if (mhd) then s_L = min(vel_L(idx) - c_fast_L, vel_R(idx) - c_fast_R) s_R = max(vel_R(idx) + c_fast_R, vel_L(idx) + c_fast_L) s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) else if (hypoelasticity) then s_L = min(vel_L(idx) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R)) + tau_e_L(idx_tau))/rho_L) & + , vel_R(idx) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & + tau_e_R(idx_tau))/rho_R)) s_R = max(vel_R(idx) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + & - tau_e_R(idx_tau))/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & - tau_e_L(idx_tau))/rho_L)) + tau_e_R(idx_tau))/rho_R) & + , vel_L(idx) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + & + tau_e_L(idx_tau))/rho_L)) s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) else if (hyperelasticity) then s_L = min(vel_L(idx) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L) & - , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + , vel_R(idx) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) s_R = max(vel_R(idx) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R) & - , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + , vel_L(idx) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) else s_L = min(vel_L(idx) - c_L, vel_R(idx) - c_R) s_R = max(vel_R(idx) + c_R, vel_L(idx) + c_L) s_S = (pres_R - pres_L + rho_L*vel_L(idx)* & - (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & - /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) + (s_L - vel_L(idx)) - rho_R*vel_R(idx)*(s_R - vel_R(idx))) & + /(rho_L*(s_L - vel_L(idx)) - rho_R*(s_R - vel_R(idx))) end if else if (wave_speeds == 2) then pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(idx) - vel_R(idx))) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 12c976b20..55b8ce1da 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -380,7 +380,7 @@ contains alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) end do - + vel_L_rms = 0._wp; vel_R_rms = 0._wp !$acc loop seq @@ -853,8 +853,8 @@ contains end do flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R))/(s_M - s_P) + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R))/(s_M - s_P) else flux_rs${XYZ}$_vf(j, k, l, E_idx) = & (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & @@ -863,7 +863,7 @@ contains /(s_M - s_P) & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp end if - + ! Elastic Stresses if (hypoelasticity) then do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow @@ -1384,9 +1384,9 @@ contains xi_PP = max(0._wp, sign(1._wp, s_R)) E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & + (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) + (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) @@ -1560,11 +1560,10 @@ contains ! Initialize all variables vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp; - gamma_L = 0._wp; gamma_R = 0._wp; - pi_inf_L = 0._wp; pi_inf_R = 0._wp; - qv_L = 0._wp; qv_R = 0._wp; - + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; !$acc loop seq do i = 1, contxe alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) @@ -1660,8 +1659,8 @@ contains if (bubbles_euler) then ! Put p_tilde in flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - & - dir_flg(dir_idx(i))*(xi_M*ptilde_L + xi_P*ptilde_R) + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - & + dir_flg(dir_idx(i))*(xi_M*ptilde_L + xi_P*ptilde_R) end if end do @@ -1758,11 +1757,10 @@ contains ! Initialize all variables vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp; - gamma_L = 0._wp; gamma_R = 0._wp; - pi_inf_L = 0._wp; pi_inf_R = 0._wp; - qv_L = 0._wp; qv_R = 0._wp; - + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) @@ -2730,11 +2728,11 @@ contains B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -2805,7 +2803,7 @@ contains U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, E_double] U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*w_double, rhoR_star*w_double, By_double, Bz_double, E_double] - + ! (7) Compute the rotational (Alfvén) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) @@ -2857,7 +2855,7 @@ contains end subroutine s_hlld_riemann_solver subroutine s_compute_hlld_state_variables(rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) + U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) implicit none ! Input parameters real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E @@ -3432,16 +3430,16 @@ contains !! @param[in] iy Y-direction loop bounds (int_bounds_info). !! @param[in] iz Z-direction loop bounds (int_bounds_info). pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) ! Arguments type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf From 30c4f8ff75bf1e7fe48c8f39a03a3a56b3ee0e2b Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Mon, 9 Jun 2025 19:08:26 -0400 Subject: [PATCH 50/58] push for testing --- src/simulation/m_riemann_solvers.fpp | 56 +++++++++++++--------------- 1 file changed, 26 insertions(+), 30 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 55b8ce1da..10a38ddfd 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2784,10 +2784,32 @@ contains E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) ! (5) Compute left/right state vectors and fluxes - call s_compute_hlld_state_variables(rho%L, vel%L, B%L, E%L, pTot_L, rhoL_star, s_M, E_starL, s_L, & - U_L, F_L, U_starL, F_starL, sqrt_rhoL_star, vL_star, wL_star) - call s_compute_hlld_state_variables(rho%R, vel%R, B%R, E%R, pTot_R, rhoR_star, s_M, E_starR, s_R, & - U_R, F_R, U_starR, F_starR, sqrt_rhoR_star, vR_star, wR_star) + U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] + U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] + U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] + U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] + + F_L(1) = U_L(2) + F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L + F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) + F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) + F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + + F_R(1) = U_R(2) + F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R + F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) + F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) + F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) + ! Compute the star flux using HLL relation + F_starL = F_L + s_M*(U_starL - U_L) + F_starR = F_R + s_M*(U_starR - U_R) + ! Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! Compute the double–star states [Miyoshi Eqns. (59)-(62)] + sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) + vL_star = vel%L(2); wL_star = vel%L(3) + vR_star = vel%R(2); wR_star = vel%R(3) ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star @@ -2851,34 +2873,8 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & norm_dir, ix, iy, iz) - end subroutine s_hlld_riemann_solver - subroutine s_compute_hlld_state_variables(rho, vel, B, E, pTot, rho_star, s_M, E_star, s_wave, & - U, F, U_star, F_star, sqrt_rho_star, v_star, w_star) - implicit none - ! Input parameters - real(wp), intent(in) :: rho, pTot, rho_star, s_M, E_star, s_wave, E - real(wp), dimension(:), intent(in) :: vel, B - ! Output parameters - real(wp), dimension(7), intent(out) :: U, F, U_star, F_star - real(wp), intent(out) :: sqrt_rho_star, v_star, w_star - ! Compute the base/star state vector - U = [rho, rho*vel(1:3), B(2:3), E] - U_star = [rho_star, rho_star*s_M, rho_star*vel(2:3), B(2:3), E_star] - ! Compute the flux vector - F(1) = U(2) - F(2) = U(2)*vel(1) - B(1)*B(1) + pTot - F(3:4) = U(2)*vel(2:3) - B(1)*B(2:3) - F(5:6) = vel(1)*B(2:3) - vel(2:3)*B(1) - F(7) = (E + pTot)*vel(1) - B(1)*(vel(1)*B(1) + vel(2)*B(2) + vel(3)*B(3)) - ! Compute the star flux using HLL relation - F_star = F + s_wave*(U_star - U) - ! Compute additional parameters needed for double-star states - sqrt_rho_star = sqrt(rho_star) - v_star = vel(2) - w_star = vel(3) - end subroutine s_compute_hlld_state_variables !> The computation of parameters, the allocation of memory, !! the association of pointers and/or the execution of any From 414eec1d2174cb361071c2f42a5e53df245fc940 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Mon, 9 Jun 2025 19:17:43 -0400 Subject: [PATCH 51/58] redo push --- src/simulation/m_riemann_solvers.fpp | 112 +++++++++++++++++---------- 1 file changed, 73 insertions(+), 39 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index a765997eb..e6e32635a 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -242,14 +242,17 @@ contains norm_dir, & ix, iy, iz) else - call s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, & + call s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & dvelL_dy_vf, & dvelL_dz_vf, & + velR_vf, & dvelR_dx_vf, & dvelR_dy_vf, & dvelR_dz_vf, & flux_src_vf, & - norm_dir) + norm_dir, & + ix, iy, iz) end if end subroutine s_compute_viscous_source_flux @@ -344,15 +347,19 @@ contains qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & + qL_prim_vf, & qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & + qR_prim_vf, & norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver( & - flux_src_vf, & - norm_dir) + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (norm_dir == ${NORM_DIR}$) then @@ -1023,7 +1030,7 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & - norm_dir) + norm_dir, ix, iy, iz) end subroutine s_hll_riemann_solver @@ -1155,16 +1162,20 @@ contains qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & + qL_prim_vf, & qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & + qR_prim_vf, & norm_dir, ix, iy, iz) ! Reshaping inputted data based on dimensional splitting direction call s_initialize_riemann_solver( & - flux_src_vf, & - norm_dir) + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 @@ -2598,6 +2609,7 @@ contains if (surface_tension) then call s_compute_capilary_source_flux( & + q_prim_vf, & vel_src_rsx_vf, & vel_src_rsy_vf, & vel_src_rsz_vf, & @@ -2607,8 +2619,10 @@ contains call s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & - norm_dir) - + norm_dir, ix, iy, iz) + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions + end subroutine s_hllc_riemann_solver !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: @@ -2666,13 +2680,13 @@ contains call s_populate_riemann_states_variables_buffers( & qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, dqL_prim_dz_vf, & + dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, & qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, dqR_prim_dz_vf, & + dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & norm_dir, ix, iy, iz) call s_initialize_riemann_solver( & - flux_src_vf, norm_dir) + q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] if (norm_dir == ${NORM_DIR}$) then @@ -2858,7 +2872,7 @@ contains #:endfor call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & - norm_dir) + norm_dir, ix, iy, iz) end subroutine s_hlld_riemann_solver @@ -3006,9 +3020,11 @@ contains qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & + qL_prim_vf, & qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & + qR_prim_vf, & norm_dir, ix, iy, iz) real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf @@ -3016,9 +3032,15 @@ contains type(scalar_field), & allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -3168,14 +3190,18 @@ contains !! @param iz Index bounds in the z-dir !! @param q_prim_vf Cell-averaged primitive variables subroutine s_initialize_riemann_solver( & - flux_src_vf, & - norm_dir) + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf type(scalar_field), & dimension(sys_size), & - intent(inout) :: flux_src_vf + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l ! Generic loop iterators ! Reshaping Inputted Data in x-direction @@ -3384,36 +3410,40 @@ contains end subroutine s_compute_cylindrical_viscous_source_flux !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - !! @param[in] ix X-direction loop bounds (int_bounds_info). - !! @param[in] iy Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Z-direction loop bounds (int_bounds_info). - pure subroutine s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, & + !! Calculates averaged velocity gradients, gets Re and interface velocities, + !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !! @param[in] ix X-direction loop bounds (int_bounds_info). + !! @param[in] iy Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Z-direction loop bounds (int_bounds_info). + pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & dvelL_dy_vf, & dvelL_dz_vf, & + velR_vf, & dvelR_dx_vf, & dvelR_dy_vf, & dvelR_dz_vf, & flux_src_vf, & - norm_dir) - + norm_dir, & + ix, iy, iz) ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz ! Local variables real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. @@ -3588,15 +3618,19 @@ contains !! @param flux_src_vf Intercell source fluxes !! @param flux_gsrc_vf Intercell geometric source fluxes !! @param norm_dir Dimensional splitting coordinate direction + !! @param ix Index bounds in first coordinate direction + !! @param iy Index bounds in second coordinate direction + !! @param iz Index bounds in third coordinate direction pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & - norm_dir) + norm_dir, ix, iy, iz) type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l !< Generic loop iterators @@ -3722,4 +3756,4 @@ contains end subroutine s_finalize_riemann_solvers_module -end module m_riemann_solvers +end module m_riemann_solvers \ No newline at end of file From 09d12879c5da56b6b8ec48423da0c476bab0b74d Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 20:22:23 -0400 Subject: [PATCH 52/58] fixed s_finalize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 136 +++++++-------------------- 1 file changed, 36 insertions(+), 100 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 36d831a43..5b2a57a49 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -4303,147 +4303,83 @@ contains ! Reshaping Outputted Data in y-direction if (norm_dir == 2) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - end do - end do - end do - end do - - if (cyl_coord) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end do - end do - end do - end do - end if - !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do j = is1%beg, is1%end do k = is2%beg, is2%end flux_src_vf(advxb)%sf(k, j, l) = & flux_src_rsy_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - end do + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if end do end do end do + end do - end if ! Reshaping Outputted Data in z-direction elseif (norm_dir == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - end do - end do - end do - end do - if (grid_geometry == 3) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end do - end do - end do - end do - end if - !$acc parallel loop collapse(3) gang vector default(present) do j = is1%beg, is1%end do k = is2%beg, is2%end do l = is3%beg, is3%end flux_src_vf(advxb)%sf(l, k, j) = & flux_src_rsz_vf(j, k, l, advxb) - end do - end do - end do - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - end do - end do - end do - end do - - end if - elseif (norm_dir == 1) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if end do end do end do end do + elseif (norm_dir == 1) then !$acc parallel loop collapse(3) gang vector default(present) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end flux_src_vf(advxb)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do end do end do end do + end if - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end do k = is2%beg, is2%end - do j = is1%beg, is1%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then flux_src_vf(i)%sf(j, k, l) = & flux_src_rsx_vf(j, k, l, i) - end do + end if end do end do end do - end if + end do end if + end subroutine s_finalize_riemann_solver !> Module deallocation and/or disassociation procedures From 60f5063be2d99728d52ff39f45445cde2c860b3c Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 20:25:24 -0400 Subject: [PATCH 53/58] s_initialize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 102 +++++++-------------------- 1 file changed, 25 insertions(+), 77 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 5b2a57a49..3182bab47 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3829,94 +3829,42 @@ contains ! Reshaping Inputted Data in x-direction - if (norm_dir == 1) then - - if (viscous .or. (surface_tension)) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in y-direction - elseif (norm_dir == 2) then - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end do j = is1%beg, is1%end - do k = is2%beg, is2%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then flux_src_vf(i)%sf(k, j, l) = 0._wp - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - end do - end do - end do - end do - end if - - ! Reshaping Inputted Data in z-direction - else - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end + else if (norm_dir == 3) then flux_src_vf(i)%sf(l, k, j) = 0._wp - end do + end if end do end do end do - end if + end do + end if - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end do + end if end do end do end do - end if - + end do end if end subroutine s_initialize_riemann_solver From 442668443f5b0bfd40b88e4967fa3c823e6d8503 Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 20:46:38 -0400 Subject: [PATCH 54/58] Update m_riemann_solvers.fpp --- src/simulation/m_riemann_solvers.fpp | 389 +++++++-------------------- 1 file changed, 91 insertions(+), 298 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 3182bab47..87a6debef 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3445,13 +3445,20 @@ contains dqR_prim_dz_vf, & norm_dir, ix, iy, iz) - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf type(scalar_field), & allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end integer, intent(in) :: norm_dir type(int_bounds_info), intent(in) :: ix, iy, iz @@ -3461,12 +3468,30 @@ contains if (norm_dir == 1) then is1 = ix; is2 = iy; is3 = iz dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - elseif (norm_dir == 2) then + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf end if !$acc update device(is1, is2, is3) @@ -3485,315 +3510,83 @@ contains !$acc update device(isx, isy, isz) ! for stuff in the same module !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - ! Population of Buffers in x-direction - if (norm_dir == 1) then - - if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(-1, k, l, i) = & - qR_prim_rsx_vf(0, k, l, i) - end do + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) end do end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dx_vf(i)%sf(-1, k, l) = & - dqR_prim_dx_vf(i)%sf(0, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dy_vf(i)%sf(-1, k, l) = & - dqR_prim_dy_vf(i)%sf(0, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqL_prim_dz_vf(i)%sf(-1, k, l) = & - dqR_prim_dz_vf(i)%sf(0, k, l) - end do - end do - end do - end if - - end if - - end if - - end if - - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(m + 1, k, l, i) = & - qL_prim_rsx_vf(m, k, l, i) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if end do end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dx_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dx_vf(i)%sf(m, k, l) - end do - end do - end do - - if (n > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dy_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dy_vf(i)%sf(m, k, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - - dqR_prim_dz_vf(i)%sf(m + 1, k, l) = & - dqL_prim_dz_vf(i)%sf(m, k, l) - end do - end do - end do - end if - - end if - - end if - end if - ! END: Population of Buffers in x-direction - - ! Population of Buffers in y-direction - elseif (norm_dir == 2) then - - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsy_vf(-1, k, l, i) = & - qR_prim_rsy_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, -1, l) = & - dqR_prim_dx_vf(i)%sf(j, 0, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, -1, l) = & - dqR_prim_dy_vf(i)%sf(j, 0, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, -1, l) = & - dqR_prim_dz_vf(i)%sf(j, 0, l) - end do - end do - end do - end if - - end if - - end if - - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + end if - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsy_vf(n + 1, k, l, i) = & - qL_prim_rsy_vf(n, k, l, i) - end do + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) end do end do - - if (viscous) then - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dx_vf(i)%sf(j, n, l) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dy_vf(i)%sf(j, n, l) - end do - end do - end do - - if (p > 0) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, n + 1, l) = & - dqL_prim_dz_vf(i)%sf(j, n, l) - end do - end do - end do - end if - - end if - - end if - ! END: Population of Buffers in y-direction - - ! Population of Buffers in z-direction - else - - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + end do + if (viscous) then !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsz_vf(-1, k, l, i) = & - qR_prim_rsz_vf(0, k, l, i) - end do - end do - end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe + do i = momxb, momxe + do l = isz%beg, isz%end do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = & - dqR_prim_dx_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = & - dqR_prim_dy_vf(i)%sf(j, k, 0) - end do - end do - end do - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = & - dqR_prim_dz_vf(i)%sf(j, k, 0) - end do - end do - end do - end if - - end if - - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsz_vf(p + 1, k, l, i) = & - qL_prim_rsz_vf(p, k, l, i) + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if end do end do end do - - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dx_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dx_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dy_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dy_vf(i)%sf(j, k, p) - end do - end do - end do - - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqR_prim_dz_vf(i)%sf(j, k, p + 1) = & - dqL_prim_dz_vf(i)%sf(j, k, p) - end do - end do - end do - end if - end if - end if ! END: Population of Buffers in z-direction From e60e9d7e4ca8b06a5968d723fab963eb8af26c80 Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 20:52:15 -0400 Subject: [PATCH 55/58] s_hlld_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 143 +++++++++------------------ 1 file changed, 44 insertions(+), 99 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 87a6debef..6c11db720 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3090,19 +3090,15 @@ contains ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic if (mhd) then if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1)] + B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1) - B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1) - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1) + B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] end if end if @@ -3153,74 +3149,37 @@ contains E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - ! (5) Compute the left/right conserved state vectors - U_L(1) = rho%L - U_L(2) = rho%L*vel%L(1) - U_L(3) = rho%L*vel%L(2) - U_L(4) = rho%L*vel%L(3) - U_L(5) = B%L(2) - U_L(6) = B%L(3) - U_L(7) = E%L - - U_R(1) = rho%R - U_R(2) = rho%R*vel%R(1) - U_R(3) = rho%R*vel%R(2) - U_R(4) = rho%R*vel%R(3) - U_R(5) = B%R(2) - U_R(6) = B%R(3) - U_R(7) = E%R - - ! (6) Compute the left/right star state vectors - U_starL(1) = rhoL_star - U_starL(2) = rhoL_star*s_M - U_starL(3) = rhoL_star*vel%L(2) - U_starL(4) = rhoL_star*vel%L(3) - U_starL(5) = B%L(2) - U_starL(6) = B%L(3) - U_starL(7) = E_starL - - U_starR(1) = rhoR_star - U_starR(2) = rhoR_star*s_M - U_starR(3) = rhoR_star*vel%R(2) - U_starR(4) = rhoR_star*vel%R(3) - U_starR(5) = B%R(2) - U_starR(6) = B%R(3) - U_starR(7) = E_starR - - ! (7) Compute the left/right fluxes - F_L(1) = rho%L*vel%L(1) - F_L(2) = rho%L*vel%L(1)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3) = rho%L*vel%L(1)*vel%L(2) - B%L(1)*B%L(2) - F_L(4) = rho%L*vel%L(1)*vel%L(3) - B%L(1)*B%L(3) - F_L(5) = vel%L(1)*B%L(2) - vel%L(2)*B%L(1) - F_L(6) = vel%L(1)*B%L(3) - vel%L(3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + ! (5) Compute left/right state vectors and fluxes + U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] + U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] + U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] + U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] - F_R(1) = rho%R*vel%R(1) - F_R(2) = rho%R*vel%R(1)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3) = rho%R*vel%R(1)*vel%R(2) - B%R(1)*B%R(2) - F_R(4) = rho%R*vel%R(1)*vel%R(3) - B%R(1)*B%R(3) - F_R(5) = vel%R(1)*B%R(2) - vel%R(2)*B%R(1) - F_R(6) = vel%R(1)*B%R(3) - vel%R(3)*B%R(1) + F_L(1) = U_L(2) + F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L + F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) + F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) + F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + + F_R(1) = U_R(2) + F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R + F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) + F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - - ! (8) Compute the left/right star fluxes (note array operations) - F_starL = F_L + s_L*(U_starL - U_L) - F_starR = F_R + s_R*(U_starR - U_R) - - ! (9) Compute the rotational (Alfvén) speeds + ! Compute the star flux using HLL relation + F_starL = F_L + s_M*(U_starL - U_L) + F_starR = F_R + s_M*(U_starR - U_R) + ! Compute the rotational (Alfvén) speeds s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! Compute the double–star states [Miyoshi Eqns. (59)-(62)] + sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) + vL_star = vel%L(2); wL_star = vel%L(3) + vR_star = vel%R(2); wR_star = vel%R(3) - ! (10) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - sqrt_rhoL_star = sqrt(rhoL_star) - sqrt_rhoR_star = sqrt(rhoR_star) + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] denom_ds = sqrt_rhoL_star + sqrt_rhoR_star sign_Bx = sign(1._wp, B%L(1)) - vL_star = vel%L(2) - wL_star = vel%L(3) - vR_star = vel%R(2) - wR_star = vel%R(3) v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds @@ -3230,23 +3189,14 @@ contains E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx E_double = 0.5_wp*(E_doubleL + E_doubleR) - U_doubleL(1) = rhoL_star - U_doubleL(2) = rhoL_star*s_M - U_doubleL(3) = rhoL_star*v_double - U_doubleL(4) = rhoL_star*w_double - U_doubleL(5) = By_double - U_doubleL(6) = Bz_double - U_doubleL(7) = E_double - - U_doubleR(1) = rhoR_star - U_doubleR(2) = rhoR_star*s_M - U_doubleR(3) = rhoR_star*v_double - U_doubleR(4) = rhoR_star*w_double - U_doubleR(5) = By_double - U_doubleR(6) = Bz_double - U_doubleR(7) = E_double - - ! (11) Choose HLLD flux based on wave-speed regions + U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, E_double] + U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*w_double, rhoR_star*w_double, By_double, Bz_double, E_double] + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions if (0.0_wp <= s_L) then F_hlld = F_L else if (0.0_wp <= s_starL) then @@ -3261,20 +3211,16 @@ contains F_hlld = F_R end if - ! (12) Reorder and write temporary variables to the flux array + ! (9) Reorder and write temporary variables to the flux array ! Mass flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component ! Momentum - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = F_hlld(2) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(2)) = F_hlld(3) - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(3)) = F_hlld(4) + flux_rs${XYZ}$_vf(j, k, l, [contxe + dir_idx(1), contxe + dir_idx(2), contxe + dir_idx(3)]) = F_hlld([2, 3, 4]) ! Magnetic field if (n == 0) then - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) = F_hlld(6) + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg, B_idx%beg + 1]) = F_hlld([5, 6]) else - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1) = F_hlld(5) - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1) = F_hlld(6) + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg + dir_idx(2) - 1, B_idx%beg + dir_idx(3) - 1]) = F_hlld([5, 6]) end if ! Energy flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) @@ -3283,7 +3229,6 @@ contains do i = advxb, advxe flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) end do - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp end do end do From 55eb06f7e58af2ea89ca05ba520e6fb6df58cff6 Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 21:12:40 -0400 Subject: [PATCH 56/58] s_finalize_riemann_solver --- src/simulation/m_riemann_solvers.fpp | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 339e6199a..fcb7b2501 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -3775,14 +3775,13 @@ contains !! @param iz Index bounds in third coordinate direction pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & flux_gsrc_vf, & - norm_dir, ix, iy, iz) + norm_dir) type(scalar_field), & dimension(sys_size), & intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz integer :: i, j, k, l !< Generic loop iterators From fe22dc2574bf47e44cee7fd8bc84381983212299 Mon Sep 17 00:00:00 2001 From: malmahrouqi3 Date: Mon, 9 Jun 2025 21:19:45 -0400 Subject: [PATCH 57/58] small change --- src/simulation/m_riemann_solvers.fpp | 7820 +++++++++++++------------- 1 file changed, 3910 insertions(+), 3910 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index fcb7b2501..717dd2d98 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -1,3911 +1,3911 @@ -!> -!! @file m_riemann_solvers.f90 -!! @brief Contains module m_riemann_solvers - -!> @brief This module features a database of approximate and exact Riemann -!! problem solvers for the Navier-Stokes system of equations, which -!! is supplemented by appropriate advection equations that are used -!! to capture the material interfaces. The closure of the system is -!! achieved by the stiffened gas equation of state and any required -!! mixture relations. Surface tension effects are accounted for and -!! are modeled by means of a volume force acting across the diffuse -!! material interface region. The implementation details of viscous -!! and capillary effects, into the Riemann solvers, may be found in -!! Perigaud and Saurel (2005). Note that both effects are available -!! only in the volume fraction model. At this time, the approximate -!! and exact Riemann solvers that are listed below are available: -!! 1) Harten-Lax-van Leer (HLL) -!! 2) Harten-Lax-van Leer-Contact (HLLC) -!! 3) Exact -!! 4) Harten-Lax-van Leer Discontinuities (HLLD) - for MHD only - -#:include 'case.fpp' -#:include 'macros.fpp' -#:include 'inline_riemann.fpp' - -module m_riemann_solvers - - use m_derived_types !< Definitions of the derived types - - use m_global_parameters !< Definitions of the global parameters - - use m_mpi_proxy !< Message passing interface (MPI) module proxy - - use m_variables_conversion !< State variables type conversion procedures - - use m_bubbles !< To get the bubble wall pressure function - - use m_bubbles_EE - - use m_surface_tension !< To get the capilary fluxes - - use m_chemistry - - use m_thermochem, only: & - gas_constant, get_mixture_molecular_weight, & - get_mixture_specific_heat_cv_mass, get_mixture_energy_mass, & - get_species_specific_heats_r, get_species_enthalpies_rt, & - get_mixture_specific_heat_cp_mass - - implicit none - - private; public :: s_initialize_riemann_solvers_module, & - s_riemann_solver, & - s_hll_riemann_solver, & - s_hllc_riemann_solver, & - s_hlld_riemann_solver, & - s_finalize_riemann_solvers_module - - !> The cell-boundary values of the fluxes (src - source) that are computed - !! through the chosen Riemann problem solver, and the direct evaluation of - !! source terms, by using the left and right states given in qK_prim_rs_vf, - !! dqK_prim_ds_vf where ds = dx, dy or dz. - !> @{ - - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf - !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & - !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) - !> @} - - !> The cell-boundary values of the geometrical source flux that are computed - !! through the chosen Riemann problem solver by using the left and right - !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. - !> @{ - - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< - real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< - !$acc declare create( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) - !> @} - - ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as - ! part of Riemann problem solution and is used to evaluate the source flux. - - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf - !$acc declare create(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) - - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf - !$acc declare create(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) - - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf - real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf - !$acc declare create(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) - - !> @name Indical bounds in the s1-, s2- and s3-directions - !> @{ - type(int_bounds_info) :: is1, is2, is3 - type(int_bounds_info) :: isx, isy, isz - !> @} - - !$acc declare create(is1, is2, is3, isx, isy, isz) - - real(wp), allocatable, dimension(:) :: Gs - !$acc declare create(Gs) - - real(wp), allocatable, dimension(:, :) :: Res - !$acc declare create(Res) - -contains - - !> Dispatch to the subroutines that are utilized to compute the - !! Riemann problem solution. For additional information please reference: - !! 1) s_hll_riemann_solver - !! 2) s_hllc_riemann_solver - !! 3) s_exact_riemann_solver - !! 4) s_hlld_riemann_solver - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf - - type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(INOUT) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz - - #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4)] - if (riemann_solver == ${NUM}$) then - call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - end if - #:endfor - - end subroutine s_riemann_solver - - !> Dispatch to the subroutines that are utilized to compute - !! the viscous source fluxes for either Cartesian or cylindrical geometries. - !! For more information please refer to: - !! 1) s_compute_cartesian_viscous_source_flux - !! 2) s_compute_cylindrical_viscous_source_flux - pure subroutine s_compute_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - - type(scalar_field), & - dimension(num_vels), & - intent(IN) :: velL_vf, velR_vf, & - dvelL_dx_vf, dvelR_dx_vf, & - dvelL_dy_vf, dvelR_dy_vf, & - dvelL_dz_vf, dvelR_dz_vf - - type(scalar_field), & - dimension(sys_size), & - intent(INOUT) :: flux_src_vf - - integer, intent(IN) :: norm_dir - - type(int_bounds_info), intent(IN) :: ix, iy, iz - - if (grid_geometry == 3) then - call s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - else - call s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - end if - end subroutine s_compute_viscous_source_flux - - subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L, flux_tau_R - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp) :: rho_L, rho_R - real(wp), dimension(num_vels) :: vel_L, vel_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R - real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi - real(wp) :: T_L, T_R - real(wp) :: Y_L, Y_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp) :: G_L, G_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp), dimension(3) :: xi_field_L, xi_field_R - - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_M, xi_P - - real(wp) :: ptilde_L, ptilde_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR - real(wp) :: alpha_L_sum, alpha_R_sum - real(wp) :: zcoef, pcorr !< low Mach number correction - - type(riemann_states) :: c_fast, pres_mag, vel - type(riemann_states_vec3) :: B - - type(riemann_states) :: Ga ! Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm ! Conservative momentum variables - - integer :: i, j, k, l, q !< Generic loop iterators - - ! Populating the buffers of the left and right Riemann problem - ! states variables, based on the choice of boundary conditions - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - call s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - - if (norm_dir == ${NORM_DIR}$) then - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & - !$acc alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, & - !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, Ys_L, Ys_R, & - !$acc xi_field_L, xi_field_R, & - !$acc Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, & - !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & - !$acc c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, & - !$acc pcorr, zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - !$acc loop seq - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_vels - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) - B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) - B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) - B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) - B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) - B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 2) - end if - end if - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - pres_mag%L = 0._wp - pres_mag%R = 0._wp - - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) - alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) - alpha_L_sum = alpha_L_sum + alpha_L(i) - alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) - alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) - alpha_R_sum = alpha_R_sum + alpha_R(i) - end do - - alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) - alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & - + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - elseif (mhd .and. relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L - b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L - b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L - b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R - b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R - b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - - cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) - cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) - cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) - cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) - cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) - cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - elseif (mhd .and. .not. relativity) then - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy - H_L = (E_L + pres_L - pres_mag%L)/rho_L - H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - else - E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! elastic energy update - if (hypoelasticity) then - G_L = 0._wp; G_R = 0._wp - - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - - if (cont_damage) then - G_L = G_L*max((1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) - G_R = G_R*max((1._wp - qR_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) - end if - - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! Elastic contribution to energy if G large enough - !TODO take out if statement if stable without - if ((G_L > 1000) .and. (G_R > 1000)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Double for shear stresses - if (any(strxb - 1 + i == shear_indices)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - ! elastic energy update - !if ( hyperelasticity ) then - ! G_L = 0._wp - ! G_R = 0._wp - ! - ! !$acc loop seq - ! do i = 1, num_fluids - ! G_L = G_L + alpha_L(i)*Gs(i) - ! G_R = G_R + alpha_R(i)*Gs(i) - ! end do - ! ! Elastic contribution to energy if G large enough - ! if ((G_L > 1e-3_wp) .and. (G_R > 1e-3_wp)) then - ! E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - ! E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - ! !$acc loop seq - ! do i = 1, b_size-1 - ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - ! tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - ! end do - ! !$acc loop seq - ! do i = 1, b_size-1 - ! tau_e_L(i) = 0_wp - ! tau_e_R(i) = 0_wp - ! end do - ! !$acc loop seq - ! do i = 1, num_dims - ! xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - ! end do - ! end if - !end if - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_sum_Yi_Phi, c_avg) - - if (mhd) then - call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) - call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) - end if - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - if (wave_speeds == 1) then - if (mhd) then - s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) - s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) - elseif (hypoelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & - (((4._wp*G_R)/3._wp) + & - tau_e_R(dir_idx_tau(1)))/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & - (((4._wp*G_L)/3._wp) + & - tau_e_L(dir_idx_tau(1)))/rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L) & - , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R) & - , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L)) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - end if - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & - (s_L - vel_L(dir_idx(1))) - & - rho_R*vel_R(dir_idx(1))* & - (s_R - vel_R(dir_idx(1)))) & - /(rho_L*(s_L - vel_L(dir_idx(1))) - & - rho_R*(s_R - vel_R(dir_idx(1)))) - elseif (wave_speeds == 2) then - pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & - (vel_L(dir_idx(1)) - & - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & - (pres_SL/pres_L - 1._wp)*pres_L/ & - ((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & - (pres_SR/pres_R - 1._wp)*pres_R/ & - ((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & - (pres_L - pres_R)/ & - (rho_avg*c_avg)) - end if - - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & - + (5e-1_wp - sign(5e-1_wp, s_L)) & - *(5e-1_wp + sign(5e-1_wp, s_R)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_R)) & - + (5e-1_wp - sign(5e-1_wp, s_L)) & - *(5e-1_wp + sign(5e-1_wp, s_R)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! Mass - if (.not. relativity) then - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(alpha_rho_L(i) & - - alpha_rho_R(i))) & - /(s_M - s_P) - end do - elseif (relativity) then - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & - - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & - + s_M*s_P*(Ga%L*alpha_rho_L(i) & - - Ga%R*alpha_rho_R(i))) & - /(s_M - s_P) - end do - end if - - ! Momentum - if (mhd .and. (.not. relativity)) then - ! Flux of rho*v_x in the ${XYZ}$ direction - ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & - - B%R(1)*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & - - B%L(1)*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & - /(s_M - s_P) - ! Flux of rho*v_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & - - B%R(2)*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & - - B%L(2)*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & - /(s_M - s_P) - ! Flux of rho*v_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & - - B%R(3)*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & - - B%L(3)*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! Flux of m_x in the ${XYZ}$ direction - ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & - (s_M*(cm%R(1)*vel_R(norm_dir) & - - b4%R(1)/Ga%R*B%R(norm_dir) & - + dir_flg(1)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(1)*vel_L(norm_dir) & - - b4%L(1)/Ga%L*B%L(norm_dir) & - + dir_flg(1)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(1) - cm%R(1))) & - /(s_M - s_P) - ! Flux of m_y in the ${XYZ}$ direction - ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - (s_M*(cm%R(2)*vel_R(norm_dir) & - - b4%R(2)/Ga%R*B%R(norm_dir) & - + dir_flg(2)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(2)*vel_L(norm_dir) & - - b4%L(2)/Ga%L*B%L(norm_dir) & - + dir_flg(2)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(2) - cm%R(2))) & - /(s_M - s_P) - ! Flux of m_z in the ${XYZ}$ direction - ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot - flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & - (s_M*(cm%R(3)*vel_R(norm_dir) & - - b4%R(3)/Ga%R*B%R(norm_dir) & - + dir_flg(3)*(pres_R + pres_mag%R)) & - - s_P*(cm%L(3)*vel_L(norm_dir) & - - b4%L(3)/Ga%L*B%L(norm_dir) & - + dir_flg(3)*(pres_L + pres_mag%L)) & - + s_M*s_P*(cm%L(3) - cm%R(3))) & - /(s_M - s_P) - elseif (bubbles_euler) then - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - else if (hypoelasticity) then - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R & - - tau_e_R(dir_idx_tau(i))) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L & - - tau_e_L(dir_idx_tau(i))) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) - end do - else - !$acc loop seq - do i = 1, num_vels - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *vel_R(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_R) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *vel_L(dir_idx(i)) & - + dir_flg(dir_idx(i))*pres_L) & - + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - - rho_R*vel_R(dir_idx(i)))) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - end if - - ! Energy - if (mhd .and. (.not. relativity)) then - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & - - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - elseif (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux - ! Hard-coded for single-component for now - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) - else if (bubbles_euler) then - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - flux_tau_L = 0._wp; flux_tau_R = 0._wp - !$acc loop seq - do i = 1, num_dims - flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) - flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & - + s_M*s_P*(E_L - E_R))/(s_M - s_P) - else - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & - - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & - + s_M*s_P*(E_L - E_R)) & - /(s_M - s_P) & - + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp - end if - - ! Elastic Stresses - if (hypoelasticity) then - do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - (s_M*(rho_R*vel_R(dir_idx(1)) & - *tau_e_R(i)) & - - s_P*(rho_L*vel_L(dir_idx(1)) & - *tau_e_L(i)) & - + s_M*s_P*(rho_L*tau_e_L(i) & - - rho_R*tau_e_R(i))) & - /(s_M - s_P) - end do - end if - - ! Advection - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - (qL_prim_rs${XYZ}$_vf(j, k, l, i) & - - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & - *s_M*s_P/(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = & - (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & - /(s_M - s_P) - end do - - ! Xi field - !if ( hyperelasticity ) then - ! do i = 1, num_dims - ! flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - ! (s_M*rho_R*vel_R(dir_idx(1))*xi_field_R(i) & - ! - s_P*rho_L*vel_L(dir_idx(1))*xi_field_L(i) & - ! + s_M*s_P*(rho_L*xi_field_L(i) & - ! - rho_R*xi_field_R(i))) & - ! /(s_M - s_P) - ! end do - !end if - - ! Div(U)? - !$acc loop seq - do i = 1, num_vels - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - (xi_M*(rho_L*vel_L(dir_idx(i))* & - (s_L - vel_L(dir_idx(1))) - & - pres_L*dir_flg(dir_idx(i))) - & - xi_P*(rho_R*vel_R(dir_idx(i))* & - (s_R - vel_R(dir_idx(1))) - & - pres_R*dir_flg(dir_idx(i)))) & - /(xi_M*rho_L*(s_L - vel_L(dir_idx(1))) - & - xi_P*rho_R*(s_R - vel_R(dir_idx(1)))) - end do - - if (bubbles_euler) then - ! From HLLC: Kills mass transport @ bubble gas density - if (num_fluids > 1) then - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp - end if - end if - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - - flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & - - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & - /(s_M - s_P) - flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - - if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 - ! B_z flux = v_x * B_z - v_z * Bx0 - !acc loop seq - do i = 0, 1 - flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & - + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) - end do - else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) - ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) - ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - !$acc loop seq - do i = 0, 2 - flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & - s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & - s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) - end do - end if - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp - end if - - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & - - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - end if - - if (cyl_coord .and. hypoelasticity) then - ! += tau_sigmasigma using HLL - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & - (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & - /(s_M - s_P) - - !$acc loop seq - do i = strxb, strxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - end if - #:endif - end do - end do - end do - end if - - #:endfor - - if (viscous) then - if (weno_Re_flux) then - - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - end if - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - end subroutine s_hll_riemann_solver - - !> This procedure is the implementation of the Harten, Lax, - !! van Leer, and contact (HLLC) approximate Riemann solver, - !! see Toro (1999) and Johnsen (2007). The viscous and the - !! surface tension effects have been included by modifying - !! the exact Riemann solver of Perigaud and Saurel (2005). - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), & - allocatable, dimension(:), & - intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp) :: rho_L, rho_R - real(wp), dimension(num_dims) :: vel_L, vel_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps - real(wp) :: T_L, T_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: Y_L, Y_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(2) :: Re_L, Re_R - - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_L, xi_R !< Left and right wave speeds functions - real(wp) :: xi_M, xi_P - real(wp) :: xi_MP, xi_PP - - real(wp) :: nbub_L, nbub_R - real(wp), dimension(nb) :: R0_L, R0_R - real(wp), dimension(nb) :: V0_L, V0_R - real(wp), dimension(nb) :: P0_L, P0_R - real(wp), dimension(nb) :: pbw_L, pbw_R - real(wp) :: ptilde_L, ptilde_R - - real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom - - real(wp) :: PbwR3Lbar, Pbwr3Rbar - real(wp) :: R3Lbar, R3Rbar - real(wp) :: R3V2Lbar, R3V2Rbar - - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp), dimension(num_dims) :: xi_field_L, xi_field_R - real(wp) :: G_L, G_R - - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star - real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R - real(wp) :: flux_ene_e - real(wp) :: zcoef, pcorr !< low Mach number correction - - integer :: i, j, k, l, q !< Generic loop iterators - integer :: idx1, idxi - type(riemann_states) :: c_fast, vel - integer :: loop_end - - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - - call s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 - - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - - if (norm_dir == ${NORM_DIR}$) then - - ! 6-EQUATION MODEL WITH HLLC - if (model_eqns == 3) then - !ME3 - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(vel_L, vel_R, vel_K_Star, Re_L, Re_R, rho_avg, h_avg, gamma_avg, & - !$acc s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R, Ys_L, Ys_R, Xs_L, Xs_R, & - !$acc Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & - !$acc tau_e_L, tau_e_R, G_L, G_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, & - !$acc zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - idx1 = dir_idx(1) - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, advxb + i - 1) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, advxb + i - 1) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if - end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp; G_R = 0_wp; - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - ! COMPUTING THE DIRECT WAVE SPEEDS - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(idx1))/(s_L - s_S) - xi_R = (s_R - vel_R(idx1))/(s_R - s_S) - - ! goes with numerical star velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(0.5_wp, s_S)) - xi_P = (5e-1_wp - sign(0.5_wp, s_S)) - - ! goes with the numerical velocity in x/y/z directions - ! xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) - xi_MP = -min(0._wp, sign(1._wp, s_L)) - xi_PP = max(0._wp, sign(1._wp, s_R)) - - E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & - xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) - p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & - xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) - - rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + & - xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) - - vel_K_Star = vel_L(idx1)*(1_wp - xi_MP) + xi_MP*vel_R(idx1) + & - xi_MP*xi_PP*(s_S - vel_R(idx1)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING FLUXES - ! MASS FLUX. - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*(vel_L(idx1) + s_M*(xi_L - 1._wp)) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = rho_Star*vel_K_Star* & - (dir_flg(idxi)*vel_K_Star + (1_wp - dir_flg(idxi))*(xi_M*vel_L(idxi) + xi_P*vel_R(idxi))) + dir_flg(idxi)*p_Star & - + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr - end do - - ! ENERGY FLUX. - ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0_wp; - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - & - xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & - s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & - xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & - s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e - end if - - ! VOLUME FRACTION FLUX. - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*s_S + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S - end do - - ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & - xi_M*(vel_L(idxi) + dir_flg(idxi)*(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(idxi))) + & - xi_P*(vel_R(idxi) + dir_flg(idxi)*(s_S*(xi_PP*(xi_R - 1) + 1) - vel_R(idxi))) - end do - - ! INTERNAL ENERGIES ADVECTION FLUX. - ! K-th pressure and velocity in preparation for the internal energy flux - !$acc loop seq - do i = 1, num_fluids - p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1_wp + gammas(i)))* & - xi_L**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_L) + pres_L) + & - xi_P*(xi_PP*((pres_R + pi_infs(i)/(1_wp + gammas(i)))* & - xi_R**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_R) + pres_R) - - flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & - ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1))* & - (gammas(i)*p_K_Star + pi_infs(i)) + & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1))* & - qvs(i))*vel_K_Star & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) - end do - end if - - ! REFERENCE MAP FLUX. - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(idx1)*xi_field_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & - - rho_R*vel_R(idx1)*xi_field_R(i)) - end do - end if - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rs${XYZ}$_vf(j, k, l, c_idx) = & - (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) + & - xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - !$acc loop seq - do i = intxb, intxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end do - end do - end do - - elseif (model_eqns == 4) then - !ME4 - !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & - !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, nbub_L, nbub_R, ptilde_L, ptilde_R) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - ! Initialize all variables - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp; - gamma_L = 0._wp; gamma_R = 0._wp; - pi_inf_L = 0._wp; pi_inf_R = 0._wp; - qv_L = 0._wp; qv_R = 0._wp; - !$acc loop seq - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - rho_L = rho_L + alpha_rho_L(i) - rho_R = rho_R + alpha_rho_R(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L - - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) - xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*alpha_rho_L(i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*alpha_rho_R(i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_L) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*pres_R) - if (bubbles_euler) then - ! Put p_tilde in - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - & - dir_flg(dir_idx(i))*(xi_M*ptilde_L + xi_P*ptilde_R) - end if - end do - - flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp - - !$acc loop seq - do i = alf_idx, alf_idx !only advect the void fraction - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Source for volume fraction advection equation - !$acc loop seq - do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) - - ! Add advection flux for bubble variables - if (bubbles_euler) then - !$acc loop seq - do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - end if - - ! Geometrical source flux for cylindrical coordinates - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - end if - #:endif - end do - end do - end do - !$acc end parallel loop - - elseif (model_eqns == 2 .and. bubbles_euler) then - !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & - !$acc rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms, Re_L, Re_R, pcorr, zcoef, vel_L_tmp, vel_R_tmp) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - ! Initialize all variables - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp; - gamma_L = 0._wp; gamma_R = 0._wp; - pi_inf_L = 0._wp; pi_inf_R = 0._wp; - qv_L = 0._wp; qv_R = 0._wp; - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_dims - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - loop_end = num_fluids - if (.not. mpp_lim .and. num_fluids > 2) loop_end = num_fluids - 1 - - ! Retain this in the refactor - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, loop_end - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - end do - else - rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - end if - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - if (mpp_lim .and. (num_fluids > 2)) then - !$acc loop seq - do i = 1, num_fluids - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - else if (num_fluids > 2) then - !$acc loop seq - do i = 1, num_fluids - 1 - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - else - rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) - gamma_R = gammas(1) - pi_inf_R = pi_infs(1) - qv_R = qvs(1) - end if - - if (viscous) then - if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & - + Re_R(i) - end do - - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - end if - - E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms - - E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - if (avg_state == 2) then - !$acc loop seq - do i = 1, nb - R0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, rs(i)) - R0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, rs(i)) - - V0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, vs(i)) - V0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, vs(i)) - if (.not. polytropic .and. .not. qbmm) then - P0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, ps(i)) - P0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, ps(i)) - end if - end do - - if (.not. qbmm) then - if (adv_n) then - nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, n_idx) - nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, n_idx) - else - nbub_L_denom = 0._wp - nbub_R_denom = 0._wp - !$acc loop seq - do i = 1, nb - nbub_L_denom = nbub_L_denom + (R0_L(i)**3._wp)*weight(i) - nbub_R_denom = nbub_R_denom + (R0_R(i)**3._wp)*weight(i) - end do - nbub_L = (3._wp/(4._wp*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom - nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom - end if - else - !nb stored in 0th moment of first R0 bin in variable conversion module - nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) - nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, bubxb) - end if - - !$acc loop seq - do i = 1, nb - if (.not. qbmm) then - if (polytropic) then - pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0._wp) - pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0._wp) - else - pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), P0_L(i)) - pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), P0_R(i)) - end if - end if - end do - - if (qbmm) then - PbwR3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 4) - PbwR3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 4) - - R3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 1) - R3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 1) - - R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) - R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) - else - - PbwR3Lbar = 0._wp - PbwR3Rbar = 0._wp - - R3Lbar = 0._wp - R3Rbar = 0._wp - - R3V2Lbar = 0._wp - R3V2Rbar = 0._wp - - !$acc loop seq - do i = 1, nb - PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) - PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) - - R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) - R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) - - R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) - R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) - end do - end if - - if (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then - ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L - else - ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & - rho_L*R3V2Lbar/R3Lbar) - end if - - if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then - ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*pres_R - else - ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & - rho_R*R3V2Rbar/R3Rbar) - end if - - if ((ptilde_L /= ptilde_L) .or. (ptilde_R /= ptilde_R)) then - end if - - rho_avg = 5e-1_wp*(rho_L + rho_R) - H_avg = 5e-1_wp*(H_L + H_R) - gamma_avg = 5e-1_wp*(gamma_L + gamma_R) - vel_avg_rms = 0._wp - - !$acc loop seq - do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (5e-1_wp*(vel_L(i) + vel_R(i)))**2._wp - end do - - end if - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, 0._wp, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) - xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - if (bubbles_euler .and. (num_fluids > 1)) then - ! Kill mass transport @ gas density - flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp - end if - - ! Momentum flux. - ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - - ! Include p_tilde - - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(i)) + & - s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(i)) + & - s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & - (1._wp - dir_flg(dir_idx(i)))* & - vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & - dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr - end do - - ! Energy flux. - ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - xi_M*(vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + & - s_M*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & - (rho_L*s_S + (pres_L - ptilde_L)/ & - (s_L - vel_L(dir_idx(1))))) - E_L)) & - + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) + & - s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & - (rho_R*s_S + (pres_R - ptilde_R)/ & - (s_R - vel_R(dir_idx(1))))) - E_R)) & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! Volume fraction flux - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - ! Source for volume fraction advection equation - !$acc loop seq - do i = 1, num_dims - vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & - xi_M*(vel_L(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(dir_idx(i)) + & - dir_flg(dir_idx(i))* & - s_P*(xi_R - 1._wp)) - - !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0._wp - end do - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) - - ! Add advection flux for bubble variables - !$acc loop seq - do i = bubxb, bubxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end do - - if (qbmm) then - flux_rs${XYZ}$_vf(j, k, l, bubxb) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end if - - if (adv_n) then - flux_rs${XYZ}$_vf(j, k, l, n_idx) = & - xi_M*nbub_L & - *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & - + xi_P*nbub_R & - *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & - xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - + xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(dir_idx(1))* & - vel_L(dir_idx(1)) + & - s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - - xi_P*(rho_R*(vel_R(dir_idx(1))* & - vel_R(dir_idx(1)) + & - s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & - (1._wp - dir_flg(dir_idx(1)))* & - vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif - end do - end do - end do - !$acc end parallel loop - else - ! 5-EQUATION MODEL WITH HLLC - !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & - !$acc rho_avg, h_avg, gamma_avg, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & - !$acc vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & - !$acc tau_e_L, tau_e_R, xi_field_L, xi_field_R, & - !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2) copyin(is1,is2,is3) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - !idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp - gamma_L = 0._wp; gamma_R = 0._wp - pi_inf_L = 0._wp; pi_inf_R = 0._wp - qv_L = 0._wp; qv_R = 0._wp - alpha_L_sum = 0._wp; alpha_R_sum = 0._wp - - !$acc loop seq - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) - vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - ! Change this by splitting it into the cases - ! present in the bubbles_euler - if (mpp_lim) then - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) - end do - - !$acc loop seq - do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) - alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - !$acc loop seq - do i = 1, num_fluids - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - !$acc loop seq - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) - gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) - rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) - end do - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_L(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_L(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - - end do - - !$acc loop seq - do i = 1, 2 - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_R(i) = 0._wp - - !$acc loop seq - do q = 1, Re_size(i) - Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & - + Re_R(i) - end do - - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - c_sum_Yi_Phi = 0.0_wp - !$acc loop seq - do i = chemxb, chemxe - Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - else - E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L - - E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - !$acc loop seq - do i = 1, strxe - strxb + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) - end if - end if - end do - end if - - ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) - xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) - end do - G_L = 0_wp - G_R = 0_wp - !$acc loop seq - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs(i) - G_R = G_R + alpha_R(i)*Gs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) - E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) - end if - !$acc loop seq - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) - tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) - end do - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & - vel_L_rms, 0._wp, c_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & - vel_R_rms, 0._wp, c_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & - vel_avg_rms, c_sum_Yi_Phi, c_avg) - - if (viscous) then - !$acc loop seq - do i = 1, 2 - Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & - c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & - tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & - s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) - - ! goes with q_star_L/R = xi_L/R * (variable) - ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) - xi_L = (s_L - vel_L(idx1))/(s_L - s_S) - xi_R = (s_R - vel_R(idx1))/(s_R - s_S) - - ! goes with numerical velocity in x/y/z directions - ! xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) - xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING THE HLLC FLUXES - ! MASS FLUX. - !$acc loop seq - do i = 1, contxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! MOMENTUM FLUX. - ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idxi) + & - s_M*(xi_L*(dir_flg(idxi)*s_S + & - (1._wp - dir_flg(idxi))* & - vel_L(idxi)) - vel_L(idxi))) + & - dir_flg(idxi)*(pres_L)) & - + xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idxi) + & - s_P*(xi_R*(dir_flg(idxi)*s_S + & - (1._wp - dir_flg(idxi))* & - vel_R(idxi)) - vel_R(idxi))) + & - dir_flg(idxi)*(pres_R)) & - + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr - end do - - ! ENERGY FLUX. - ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - flux_rs${XYZ}$_vf(j, k, l, E_idx) = & - xi_M*(vel_L(idx1)*(E_L + pres_L) + & - s_M*(xi_L*(E_L + (s_S - vel_L(idx1))* & - (rho_L*s_S + pres_L/ & - (s_L - vel_L(idx1)))) - E_L)) & - + xi_P*(vel_R(idx1)*(E_R + pres_R) + & - s_P*(xi_R*(E_R + (s_S - vel_R(idx1))* & - (rho_R*s_S + pres_R/ & - (s_R - vel_R(idx1)))) - E_R)) & - + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0_wp - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - ! MOMENTUM ELASTIC FLUX. - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & - flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & - - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - & - xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & - s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & - xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & - s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e - end if - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - !$acc loop seq - do i = 1, strxe - strxb + 1 - flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) - end do - end if - - ! VOLUME FRACTION FLUX. - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end do - - ! VOLUME FRACTION SOURCE FLUX. - !$acc loop seq - do i = 1, num_dims - idxi = dir_idx(i) - vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & - xi_M*(vel_L(idxi) + & - dir_flg(idxi)* & - s_M*(xi_L - 1._wp)) & - + xi_P*(vel_R(idxi) + & - dir_flg(idxi)* & - s_P*(xi_R - 1._wp)) - end do - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rs${XYZ}$_vf(j, k, l, c_idx) = & - xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) & - *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx) & - *(vel_R(idx1) + s_P*(xi_R - 1._wp)) - end if - - ! REFERENCE MAP FLUX. - if (hyperelasticity) then - !$acc loop seq - do i = 1, num_dims - flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & - xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - - rho_L*vel_L(idx1)*xi_field_L(i)) + & - xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & - - rho_R*vel_R(idx1)*xi_field_R(i)) - end do - end if - - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) - - if (chemistry) then - !$acc loop seq - do i = chemxb, chemxe - Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) - Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - - flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*rho_L*Y_L*(vel_L(idx1) + s_M*(xi_L - 1._wp)) & - + xi_P*rho_R*Y_R*(vel_R(idx1) + s_P*(xi_R - 1._wp)) - flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp - end do - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - !Substituting the advective flux into the inviscid geometrical source flux - !$acc loop seq - do i = 1, E_idx - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & - xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - + xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - ! Geometrical source of the void fraction(s) is zero - !$acc loop seq - do i = advxb, advxe - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - !$acc loop seq - do i = 1, sys_size - flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp - end do - - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & - -xi_M*(rho_L*(vel_L(idx1)* & - vel_L(idx1) + & - s_M*(xi_L*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_L(idx1)) - vel_L(idx1)))) & - - xi_P*(rho_R*(vel_R(idx1)* & - vel_R(idx1) + & - s_P*(xi_R*(dir_flg(idx1)*s_S + & - (1._wp - dir_flg(idx1))* & - vel_R(idx1)) - vel_R(idx1)))) - flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) - - end if - #:endif - end do - end do - end do - !$acc end parallel loop - end if - end if - #:endfor - ! Computing HLLC flux and source flux for Euler system of equations - - if (viscous) then - if (weno_Re_flux) then - call s_compute_viscous_source_flux( & - qL_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - qR_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux( & - q_prim_vf(momxb:momxe), & - dqL_prim_dx_vf(momxb:momxe), & - dqL_prim_dy_vf(momxb:momxe), & - dqL_prim_dz_vf(momxb:momxe), & - q_prim_vf(momxb:momxe), & - dqR_prim_dx_vf(momxb:momxe), & - dqR_prim_dy_vf(momxb:momxe), & - dqR_prim_dz_vf(momxb:momxe), & - flux_src_vf, norm_dir, ix, iy, iz) - end if - end if - - if (surface_tension) then - call s_compute_capilary_source_flux( & - q_prim_vf, & - vel_src_rsx_vf, & - vel_src_rsy_vf, & - vel_src_rsz_vf, & - flux_src_vf, & - norm_dir, isx, isy, isz) - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir) - - end subroutine s_hllc_riemann_solver - - !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: - !! 1 entropy wave, 2 Alfvén waves, 2 fast magnetosonic waves. - subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables: - real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R - type(riemann_states_vec3) :: vel - type(riemann_states) :: rho, pres, E, H_no_mag - type(riemann_states) :: gamma, pi_inf, qv - type(riemann_states) :: vel_rms - - type(riemann_states_vec3) :: B - type(riemann_states) :: c, c_fast, pres_mag - - ! HLLD speeds and intermediate state variables: - real(wp) :: s_L, s_R, s_M, s_starL, s_starR - real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR - - real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR - real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - - ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) - ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction - ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction - - real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx - real(wp) :: vL_star, vR_star, wL_star, wR_star - real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double - - integer :: i, j, k, l - - call s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & - norm_dir, ix, iy, iz) - - call s_initialize_riemann_solver( & - q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] - if (norm_dir == ${NORM_DIR}$) then - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, & - !$acc rho, pres, E, H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, & - !$acc U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - - ! (1) Extract the left/right primitive states - do i = 1, contxe - alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) - alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) - end do - - ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic - do i = 1, num_vels - vel%L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - vel%R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + dir_idx(i)) - end do - - vel_rms%L = sum(vel%L**2._wp) - vel_rms%R = sum(vel%R**2._wp) - - do i = 1, num_fluids - alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) - alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) - end do - - pres%L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) - pres%R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) - - ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1)] - B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] - else ! 2D/3D: Bx, By, Bz as variables - B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & - qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] - B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & - qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] - end if - end if - - ! Sum properties of all fluid components - rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp - rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp - !$acc loop seq - do i = 1, num_fluids - rho%L = rho%L + alpha_rho_L(i) - gamma%L = gamma%L + alpha_L(i)*gammas(i) - pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) - qv%L = qv%L + alpha_rho_L(i)*qvs(i) - - rho%R = rho%R + alpha_rho_R(i) - gamma%R = gamma%R + alpha_R(i)*gammas(i) - pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) - qv%R = qv%R + alpha_rho_R(i)*qvs(i) - end do - - pres_mag%L = 0.5_wp*sum(B%L**2._wp) - pres_mag%R = 0.5_wp*sum(B%R**2._wp) - E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L - E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy - H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L - H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - - ! (2) Compute fast wave speeds - call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, 0._wp, c%L) - call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, 0._wp, c%R) - call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) - call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) - - ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] - s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) - s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) - - pTot_L = pres%L + pres_mag%L - pTot_R = pres%R + pres_mag%R - - s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - & - (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/ & - ((s_R - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) - - ! (4) Compute star state variables - rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) - rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) - p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) - E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) - E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - - ! (5) Compute left/right state vectors and fluxes - U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] - U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] - U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] - U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] - - F_L(1) = U_L(2) - F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) - F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) - - F_R(1) = U_R(2) - F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) - F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) - F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - ! Compute the star flux using HLL relation - F_starL = F_L + s_M*(U_starL - U_L) - F_starR = F_R + s_M*(U_starR - U_R) - ! Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - ! Compute the double–star states [Miyoshi Eqns. (59)-(62)] - sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) - vL_star = vel%L(2); wL_star = vel%L(3) - vR_star = vel%R(2); wR_star = vel%R(3) - - ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] - denom_ds = sqrt_rhoL_star + sqrt_rhoR_star - sign_Bx = sign(1._wp, B%L(1)) - v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds - w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds - By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds - Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star - wL_star)*sign_Bx)/denom_ds - - E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx - E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx - E_double = 0.5_wp*(E_doubleL + E_doubleR) - - U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, E_double] - U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*w_double, rhoR_star*w_double, By_double, Bz_double, E_double] - - ! (7) Compute the rotational (Alfvén) speeds - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - - ! (8) Choose HLLD flux based on wave-speed regions - if (0.0_wp <= s_L) then - F_hlld = F_L - else if (0.0_wp <= s_starL) then - F_hlld = F_L + s_L*(U_starL - U_L) - else if (0.0_wp <= s_M) then - F_hlld = F_starL + s_starL*(U_doubleL - U_starL) - else if (0.0_wp <= s_starR) then - F_hlld = F_starR + s_starR*(U_doubleR - U_starR) - else if (0.0_wp <= s_R) then - F_hlld = F_R + s_R*(U_starR - U_R) - else - F_hlld = F_R - end if - - ! (9) Reorder and write temporary variables to the flux array - ! Mass - flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component - ! Momentum - flux_rs${XYZ}$_vf(j, k, l, [contxe + dir_idx(1), contxe + dir_idx(2), contxe + dir_idx(3)]) = F_hlld([2, 3, 4]) - ! Magnetic field - if (n == 0) then - flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg, B_idx%beg + 1]) = F_hlld([5, 6]) - else - flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg + dir_idx(2) - 1, B_idx%beg + dir_idx(3) - 1]) = F_hlld([5, 6]) - end if - ! Energy - flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) - ! Partial fraction - !$acc loop seq - do i = advxb, advxe - flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) - end do - flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp - end do - end do - end do - !$acc end parallel loop - end if - #:endfor - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & - norm_dir) - end subroutine s_hlld_riemann_solver - - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures that are necessary to setup the module. - impure subroutine s_initialize_riemann_solvers_module - - ! Allocating the variables that will be utilized to formulate the - ! left, right, and average states of the Riemann problem, as well - ! the Riemann problem solution - integer :: i, j - - @:ALLOCATE(Gs(1:num_fluids)) - - do i = 1, num_fluids - Gs(i) = fluid_pp(i)%G - end do - !$acc update device(Gs) - - if (viscous) then - @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) - end if - - if (viscous) then - do i = 1, 2 - do j = 1, Re_size(i) - Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) - end do - end do - !$acc update device(Res, Re_idx, Re_size) - end if - - !$acc enter data copyin(is1, is2, is3, isx, isy, isz) - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = m; is2%end = n; is3%end = p - - @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - if (qbmm) then - @:ALLOCATE(mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - if (n == 0) return - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = n; is2%end = m; is3%end = p - - @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - - if (qbmm) then - @:ALLOCATE(mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - if (p == 0) return - - is1%beg = -1; is2%beg = 0; is3%beg = 0 - is1%end = p; is2%end = n; is3%end = m - - @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:sys_size)) - @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, advxb:sys_size)) - @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:num_vels)) - - if (qbmm) then - @:ALLOCATE(mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) - end if - - if (viscous) then - @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, & - is2%beg:is2%end, & - is3%beg:is3%end, 1:2)) - end if - - end subroutine s_initialize_riemann_solvers_module - - !> The purpose of this subroutine is to populate the buffers - !! of the left and right Riemann states variables, depending - !! on the boundary conditions. - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the - !! first-order x-dir spatial derivatives - !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the - !! first-order y-dir spatial derivatives - !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the - !! first-order z-dir spatial derivatives - !! @param gm_alphaL_vf Left averaged gradient magnitude - !! @param gm_alphaR_vf Right averaged gradient magnitude - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - subroutine s_populate_riemann_states_variables_buffers( & - qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & - dqL_prim_dy_vf, & - dqL_prim_dz_vf, & - qL_prim_vf, & - qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & - dqR_prim_dy_vf, & - dqR_prim_dz_vf, & - qR_prim_vf, & - norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf - real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf - - type(scalar_field), & - allocatable, dimension(:), & - target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & - dqL_prim_dy_vf, dqR_prim_dy_vf, & - dqL_prim_dz_vf, dqR_prim_dz_vf, & - qL_prim_vf, qR_prim_vf - type(scalar_field), & - dimension(:), & - pointer :: dqL_prim_d_vf, dqR_prim_d_vf - - integer :: end_val, bc_beg, bc_end - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l !< Generic loop iterator - - if (norm_dir == 1) then - is1 = ix; is2 = iy; is3 = iz - dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - bc_beg = bc_x%beg; bc_end = bc_x%end - end_val = m - qL_prim_rs_vf => qL_prim_rsx_vf - qR_prim_rs_vf => qR_prim_rsx_vf - dqL_prim_d_vf => dqL_prim_dx_vf - dqR_prim_d_vf => dqR_prim_dx_vf - else if (norm_dir == 2) then - is1 = iy; is2 = ix; is3 = iz - dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) - bc_beg = bc_y%beg; bc_end = bc_y%end - end_val = n - qL_prim_rs_vf => qL_prim_rsy_vf - qR_prim_rs_vf => qR_prim_rsy_vf - dqL_prim_d_vf => dqL_prim_dy_vf - dqR_prim_d_vf => dqR_prim_dy_vf - else - is1 = iz; is2 = iy; is3 = ix - dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) - bc_beg = bc_z%beg; bc_end = bc_z%end - end_val = p - qL_prim_rs_vf => qL_prim_rsz_vf - qR_prim_rs_vf => qR_prim_rsz_vf - dqL_prim_d_vf => dqL_prim_dz_vf - dqR_prim_d_vf => dqR_prim_dz_vf - end if - - !$acc update device(is1, is2, is3) - - if (elasticity) then - if (norm_dir == 1) then - dir_idx_tau = (/1, 2, 4/) - else if (norm_dir == 2) then - dir_idx_tau = (/3, 2, 5/) - else - dir_idx_tau = (/6, 4, 5/) - end if - end if - - isx = ix; isy = iy; isz = iz - !$acc update device(isx, isy, isz) ! for stuff in the same module - !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules - - ! Population of Buffers in x/y/z-direction - if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) - end do - end do - end do - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) - if (n > 0) then - dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) - end if - end if - else if (norm_dir == 2) then - dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) - dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) - if (p > 0) then - dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) - end if - else - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) - end if - end do - end do - end do - end if - end if - - if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - !$acc parallel loop collapse(3) gang vector default(present) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) - end do - end do - end do - if (viscous) then - !$acc parallel loop collapse(3) gang vector default(present) - do i = momxb, momxe - do l = isz%beg, isz%end - do k = isy%beg, isy%end - if (norm_dir == 1) then - dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) - if (n > 0) then - dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) - end if - end if - else if (norm_dir == 2) then - dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) - dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) - if (p > 0) then - dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) - end if - else - dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) - dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) - dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) - end if - end do - end do - end do - end if - end if - ! END: Population of Buffers in z-direction - - end subroutine s_populate_riemann_states_variables_buffers - - !> The computation of parameters, the allocation of memory, - !! the association of pointers and/or the execution of any - !! other procedures needed to configure the chosen Riemann - !! solver algorithm. - !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the - !! cell-average primitive variables - !! @param flux_vf Intra-cell fluxes - !! @param flux_src_vf Intra-cell fluxes sources - !! @param flux_gsrc_vf Intra-cell geometric fluxes sources - !! @param norm_dir Dir. splitting direction - !! @param ix Index bounds in the x-dir - !! @param iy Index bounds in the y-dir - !! @param iz Index bounds in the z-dir - !! @param q_prim_vf Cell-averaged primitive variables - subroutine s_initialize_riemann_solver( & - q_prim_vf, & - flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir, ix, iy, iz) - - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - integer :: i, j, k, l ! Generic loop iterators - - ! Reshaping Inputted Data in x-direction - - if (viscous .or. (surface_tension)) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = momxb, E_idx - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = 0._wp - else if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if - end do - end do - end do - end do - end if - - if (qbmm) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - if (norm_dir == 1) then - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - else if (norm_dir == 2) then - mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) - else if (norm_dir == 3) then - mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) - end if - end do - end do - end do - end do - end if - - end subroutine s_initialize_riemann_solver - - !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. - !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives - !! and cylindrical geometric factors, then updates `flux_src_vf`. - !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). - !! @param[in] velL_vf Left boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary $\partial v_i/\partial x$ (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary $\partial v_i/\partial y$ (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary $\partial v_i/\partial z$ (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary $\partial v_i/\partial x$ (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary $\partial v_i/\partial y$ (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary $\partial v_i/\partial z$ (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). - !! @param[in] ix Global X-direction loop bounds (int_bounds_info). - !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). - pure subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & - dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & - flux_src_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). - - real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). - real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. - - real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. - real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. - real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. - real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. - - integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. - integer :: i_vel !!< Loop iterator for velocity components. - integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & - !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & - !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface - ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - !$acc loop seq - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & - dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & - dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if - if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & - dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp - end if - end do - - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - Re_s = Re_avg_rsy_vf(k, j, l, 1) - Re_b = Re_avg_rsy_vf(k, j, l, 2) - vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - Re_s = Re_avg_rsz_vf(l, k, j, 1) - Re_b = Re_avg_rsz_vf(l, k, j, 2) - vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) - r_eff = y_cc(k) - end select - - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff - if (num_dims > 2) then - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff - end if - - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp - - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - end if - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const - if (num_dims > 2) then - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - end if - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const - end if - end select - - !$acc loop seq - do i_vel = 1, num_dims - flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if - - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b - - flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk - end if - - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cylindrical_viscous_source_flux - - !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. - !! Calculates averaged velocity gradients, gets Re and interface velocities, - !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. - !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). - !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). - !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). - !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). - !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). - !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). - !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). - !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). - !! @param[in] ix X-direction loop bounds (int_bounds_info). - !! @param[in] iy Y-direction loop bounds (int_bounds_info). - !! @param[in] iz Z-direction loop bounds (int_bounds_info). - pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & - dvelL_dx_vf, & - dvelL_dy_vf, & - dvelL_dz_vf, & - velR_vf, & - dvelR_dx_vf, & - dvelR_dy_vf, & - dvelR_dz_vf, & - flux_src_vf, & - norm_dir, & - ix, iy, iz) - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - - real(wp) :: divergence_v !< Velocity divergence at interface. - - !$acc parallel loop collapse(3) gang vector default(present) & - !$acc private(idx_right_phys, vel_grad_avg, & - !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & - !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - if (num_dims > 1) then - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - if (num_dims > 2) then - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & - dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) - end if - end do - - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) - end do - - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) - Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) - end do - else - Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) - Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) - end do - end if - - if (shear_stress) then - ! current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do - end if - - if (bulk_stress) then - ! current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - - do i_dim = 1, num_dims - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) - - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & - flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do - end if - - end do - end do - end do - !$acc end parallel loop - - end subroutine s_compute_cartesian_viscous_source_flux - - !> @brief Calculates shear stress tensor components. - !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear - !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). - !! @param[in] Re_shear Shear Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). - pure subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - !$acc routine seq - - implicit none - - ! Arguments - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out - - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. - - tau_shear_out = 0.0_wp - - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & - (2.0_wp/3.0_wp)*divergence_v/Re_shear - end if - end do - end do - - end subroutine s_calculate_shear_stress_tensor - - !> @brief Calculates bulk stress tensor components (diagonal only). - !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. - !! @param[in] Re_bulk Bulk Reynolds number. - !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). - !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). - pure subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - !$acc routine seq - - implicit none - - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. - - tau_bulk_out = 0.0_wp - - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do - - end subroutine s_calculate_bulk_stress_tensor - - !> Deallocation and/or disassociation procedures that are - !! needed to finalize the selected Riemann problem solver - !! @param flux_vf Intercell fluxes - !! @param flux_src_vf Intercell source fluxes - !! @param flux_gsrc_vf Intercell geometric source fluxes - !! @param norm_dir Dimensional splitting coordinate direction - !! @param ix Index bounds in first coordinate direction - !! @param iy Index bounds in second coordinate direction - !! @param iz Index bounds in third coordinate direction - pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & - flux_gsrc_vf, & - norm_dir) - - type(scalar_field), & - dimension(sys_size), & - intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - - integer, intent(in) :: norm_dir - - integer :: i, j, k, l !< Generic loop iterators - - ! Reshaping Outputted Data in y-direction - if (norm_dir == 2) then - !$acc parallel loop collapse(3) gang vector default(present) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(advxb)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(k, j, l) = & - flux_rsy_vf(j, k, l, i) - if (cyl_coord) then - flux_gsrc_vf(i)%sf(k, j, l) = & - flux_gsrc_rsy_vf(j, k, l, i) - end if - end do - end do - end do - end do - - ! Reshaping Outputted Data in z-direction - elseif (norm_dir == 3) then - !$acc parallel loop collapse(3) gang vector default(present) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(advxb)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(l, k, j) = & - flux_rsz_vf(j, k, l, i) - if (grid_geometry == 3) then - flux_gsrc_vf(i)%sf(l, k, j) = & - flux_gsrc_rsz_vf(j, k, l, i) - end if - end do - end do - end do - end do - - elseif (norm_dir == 1) then - !$acc parallel loop collapse(3) gang vector default(present) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(advxb)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, advxb) - do i = 1, sys_size - flux_vf(i)%sf(j, k, l) = & - flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - end if - - if (riemann_solver == 1 .or. riemann_solver == 4) then - !$acc parallel loop collapse(4) gang vector default(present) - do i = advxb + 1, advxe - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (norm_dir == 2) then - flux_src_vf(i)%sf(k, j, l) = & - flux_src_rsy_vf(j, k, l, i) - else if (norm_dir == 3) then - flux_src_vf(i)%sf(l, k, j) = & - flux_src_rsz_vf(j, k, l, i) - else if (norm_dir == 1) then - flux_src_vf(i)%sf(j, k, l) = & - flux_src_rsx_vf(j, k, l, i) - end if - end do - end do - end do - end do - end if - - - end subroutine s_finalize_riemann_solver - - !> Module deallocation and/or disassociation procedures - impure subroutine s_finalize_riemann_solvers_module - - if (viscous) then - @:DEALLOCATE(Re_avg_rsx_vf) - end if - @:DEALLOCATE(vel_src_rsx_vf) - @:DEALLOCATE(flux_rsx_vf) - @:DEALLOCATE(flux_src_rsx_vf) - @:DEALLOCATE(flux_gsrc_rsx_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsx_vf) - end if - - if (n == 0) return - - if (viscous) then - @:DEALLOCATE(Re_avg_rsy_vf) - end if - @:DEALLOCATE(vel_src_rsy_vf) - @:DEALLOCATE(flux_rsy_vf) - @:DEALLOCATE(flux_src_rsy_vf) - @:DEALLOCATE(flux_gsrc_rsy_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsy_vf) - end if - - if (p == 0) return - - if (viscous) then - @:DEALLOCATE(Re_avg_rsz_vf) - end if - @:DEALLOCATE(vel_src_rsz_vf) - @:DEALLOCATE(flux_rsz_vf) - @:DEALLOCATE(flux_src_rsz_vf) - @:DEALLOCATE(flux_gsrc_rsz_vf) - if (qbmm) then - @:DEALLOCATE(mom_sp_rsz_vf) - end if - - end subroutine s_finalize_riemann_solvers_module - +!> +!! @file m_riemann_solvers.f90 +!! @brief Contains module m_riemann_solvers + +!> @brief This module features a database of approximate and exact Riemann +!! problem solvers for the Navier-Stokes system of equations, which +!! is supplemented by appropriate advection equations that are used +!! to capture the material interfaces. The closure of the system is +!! achieved by the stiffened gas equation of state and any required +!! mixture relations. Surface tension effects are accounted for and +!! are modeled by means of a volume force acting across the diffuse +!! material interface region. The implementation details of viscous +!! and capillary effects, into the Riemann solvers, may be found in +!! Perigaud and Saurel (2005). Note that both effects are available +!! only in the volume fraction model. At this time, the approximate +!! and exact Riemann solvers that are listed below are available: +!! 1) Harten-Lax-van Leer (HLL) +!! 2) Harten-Lax-van Leer-Contact (HLLC) +!! 3) Exact +!! 4) Harten-Lax-van Leer Discontinuities (HLLD) - for MHD only + +#:include 'case.fpp' +#:include 'macros.fpp' +#:include 'inline_riemann.fpp' + +module m_riemann_solvers + + use m_derived_types !< Definitions of the derived types + + use m_global_parameters !< Definitions of the global parameters + + use m_mpi_proxy !< Message passing interface (MPI) module proxy + + use m_variables_conversion !< State variables type conversion procedures + + use m_bubbles !< To get the bubble wall pressure function + + use m_bubbles_EE + + use m_surface_tension !< To get the capilary fluxes + + use m_chemistry + + use m_thermochem, only: & + gas_constant, get_mixture_molecular_weight, & + get_mixture_specific_heat_cv_mass, get_mixture_energy_mass, & + get_species_specific_heats_r, get_species_enthalpies_rt, & + get_mixture_specific_heat_cp_mass + + implicit none + + private; public :: s_initialize_riemann_solvers_module, & + s_riemann_solver, & + s_hll_riemann_solver, & + s_hllc_riemann_solver, & + s_hlld_riemann_solver, & + s_finalize_riemann_solvers_module + + !> The cell-boundary values of the fluxes (src - source) that are computed + !! through the chosen Riemann problem solver, and the direct evaluation of + !! source terms, by using the left and right states given in qK_prim_rs_vf, + !! dqK_prim_ds_vf where ds = dx, dy or dz. + !> @{ + + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsx_vf, flux_src_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsy_vf, flux_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: flux_rsz_vf, flux_src_rsz_vf + !$acc declare create( flux_rsx_vf, flux_src_rsx_vf, flux_rsy_vf, & + !$acc flux_src_rsy_vf, flux_rsz_vf, flux_src_rsz_vf ) + !> @} + + !> The cell-boundary values of the geometrical source flux that are computed + !! through the chosen Riemann problem solver by using the left and right + !! states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. + !> @{ + + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsx_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsy_vf !< + real(wp), allocatable, dimension(:, :, :, :) :: flux_gsrc_rsz_vf !< + !$acc declare create( flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf ) + !> @} + + ! The cell-boundary values of the velocity. vel_src_rs_vf is determined as + ! part of Riemann problem solution and is used to evaluate the source flux. + + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: vel_src_rsz_vf + !$acc declare create(vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf) + + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: mom_sp_rsz_vf + !$acc declare create(mom_sp_rsx_vf, mom_sp_rsy_vf, mom_sp_rsz_vf) + + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsx_vf + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsy_vf + real(wp), allocatable, dimension(:, :, :, :) :: Re_avg_rsz_vf + !$acc declare create(Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf) + + !> @name Indical bounds in the s1-, s2- and s3-directions + !> @{ + type(int_bounds_info) :: is1, is2, is3 + type(int_bounds_info) :: isx, isy, isz + !> @} + + !$acc declare create(is1, is2, is3, isx, isy, isz) + + real(wp), allocatable, dimension(:) :: Gs + !$acc declare create(Gs) + + real(wp), allocatable, dimension(:, :) :: Res + !$acc declare create(Res) + +contains + + !> Dispatch to the subroutines that are utilized to compute the + !! Riemann problem solution. For additional information please reference: + !! 1) s_hll_riemann_solver + !! 2) s_hllc_riemann_solver + !! 3) s_exact_riemann_solver + !! 4) s_hlld_riemann_solver + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(INOUT) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(IN) :: q_prim_vf + + type(scalar_field), allocatable, dimension(:), intent(INOUT) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(INOUT) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), & + dimension(sys_size), & + intent(INOUT) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(IN) :: norm_dir + + type(int_bounds_info), intent(IN) :: ix, iy, iz + + #:for NAME, NUM in [('hll', 1), ('hllc', 2), ('hlld', 4)] + if (riemann_solver == ${NUM}$) then + call s_${NAME}$_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + end if + #:endfor + + end subroutine s_riemann_solver + + !> Dispatch to the subroutines that are utilized to compute + !! the viscous source fluxes for either Cartesian or cylindrical geometries. + !! For more information please refer to: + !! 1) s_compute_cartesian_viscous_source_flux + !! 2) s_compute_cylindrical_viscous_source_flux + pure subroutine s_compute_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + + type(scalar_field), & + dimension(num_vels), & + intent(IN) :: velL_vf, velR_vf, & + dvelL_dx_vf, dvelR_dx_vf, & + dvelL_dy_vf, dvelR_dy_vf, & + dvelL_dz_vf, dvelR_dz_vf + + type(scalar_field), & + dimension(sys_size), & + intent(INOUT) :: flux_src_vf + + integer, intent(IN) :: norm_dir + + type(int_bounds_info), intent(IN) :: ix, iy, iz + + if (grid_geometry == 3) then + call s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + else + call s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + end if + end subroutine s_compute_viscous_source_flux + + subroutine s_hll_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + real(wp) :: flux_tau_L, flux_tau_R + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_vels) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R + real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi + real(wp) :: T_L, T_R + real(wp) :: Y_L, Y_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp), dimension(3) :: xi_field_L, xi_field_R + + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_M, xi_P + + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum + real(wp) :: zcoef, pcorr !< low Mach number correction + + type(riemann_states) :: c_fast, pres_mag, vel + type(riemann_states_vec3) :: B + + type(riemann_states) :: Ga ! Gamma (Lorentz factor) + type(riemann_states) :: vdotB, B2 + type(riemann_states_vec3) :: b4 ! 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm ! Conservative momentum variables + + integer :: i, j, k, l, q !< Generic loop iterators + + ! Populating the buffers of the left and right Riemann problem + ! states variables, based on the choice of boundary conditions + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + call s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + + if (norm_dir == ${NORM_DIR}$) then + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & + !$acc alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, & + !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, Ys_L, Ys_R, & + !$acc xi_field_L, xi_field_R, & + !$acc Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, & + !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & + !$acc c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, & + !$acc pcorr, zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + !$acc loop seq + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + !$acc loop seq + do i = 1, num_vels + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables + B%L(1) = Bx0 + B%R(1) = Bx0 + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + else ! 2D/3D: Bx, By, Bz as variables + B%L(1) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg) + B%R(1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg) + B%L(2) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1) + B%R(2) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1) + B%L(3) = qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 2) + B%R(3) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 2) + end if + end if + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + pres_mag%L = 0._wp + pres_mag%R = 0._wp + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) + alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) + alpha_L_sum = alpha_L_sum + alpha_L(i) + alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) + alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) + alpha_R_sum = alpha_R_sum + alpha_R(i) + end do + + alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) + alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res(i, q) & + + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + elseif (mhd .and. relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + b4%L(1) = B%L(1)/Ga%L + Ga%L*vel_L(1)*vdotB%L + b4%L(2) = B%L(2)/Ga%L + Ga%L*vel_L(2)*vdotB%L + b4%L(3) = B%L(3)/Ga%L + Ga%L*vel_L(3)*vdotB%L + b4%R(1) = B%R(1)/Ga%R + Ga%R*vel_R(1)*vdotB%R + b4%R(2) = B%R(2)/Ga%R + Ga%R*vel_R(2)*vdotB%R + b4%R(3) = B%R(3)/Ga%R + Ga%R*vel_R(3)*vdotB%R + B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp + B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp + + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + + cm%L(1) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1) - vdotB%L*B%L(1) + cm%L(2) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(2) - vdotB%L*B%L(2) + cm%L(3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(3) - vdotB%L*B%L(3) + cm%R(1) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1) - vdotB%R*B%R(1) + cm%R(2) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(2) - vdotB%R*B%R(2) + cm%R(3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(3) - vdotB%R*B%R(3) + + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + elseif (mhd .and. .not. relativity) then + pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) + pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R ! includes magnetic energy + H_L = (E_L + pres_L - pres_mag%L)/rho_L + H_R = (E_R + pres_R - pres_mag%R)/rho_R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + else + E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! elastic energy update + if (hypoelasticity) then + G_L = 0._wp; G_R = 0._wp + + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + + if (cont_damage) then + G_L = G_L*max((1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) + G_R = G_R*max((1._wp - qR_prim_rs${XYZ}$_vf(j, k, l, damage_idx)), 0._wp) + end if + + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + ! Elastic contribution to energy if G large enough + !TODO take out if statement if stable without + if ((G_L > 1000) .and. (G_R > 1000)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Double for shear stresses + if (any(strxb - 1 + i == shear_indices)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + ! elastic energy update + !if ( hyperelasticity ) then + ! G_L = 0._wp + ! G_R = 0._wp + ! + ! !$acc loop seq + ! do i = 1, num_fluids + ! G_L = G_L + alpha_L(i)*Gs(i) + ! G_R = G_R + alpha_R(i)*Gs(i) + ! end do + ! ! Elastic contribution to energy if G large enough + ! if ((G_L > 1e-3_wp) .and. (G_R > 1e-3_wp)) then + ! E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + ! E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + ! !$acc loop seq + ! do i = 1, b_size-1 + ! tau_e_L(i) = G_L*qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + ! tau_e_R(i) = G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + ! end do + ! !$acc loop seq + ! do i = 1, b_size-1 + ! tau_e_L(i) = 0_wp + ! tau_e_R(i) = 0_wp + ! end do + ! !$acc loop seq + ! do i = 1, num_dims + ! xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + ! xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + ! end do + ! end if + !end if + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, c_sum_Yi_Phi, c_avg) + + if (mhd) then + call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) + call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) + end if + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + if (wave_speeds == 1) then + if (mhd) then + s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) + s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) + elseif (hypoelasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + & + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + & + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + & + (((4._wp*G_R)/3._wp) + & + tau_e_R(dir_idx_tau(1)))/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + & + (((4._wp*G_L)/3._wp) + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + else if (hyperelasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L) & + , vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4_wp*G_R/3_wp)/rho_R) & + , vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4_wp*G_L/3_wp)/rho_L)) + else + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + end if + + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))* & + (s_L - vel_L(dir_idx(1))) - & + rho_R*vel_R(dir_idx(1))* & + (s_R - vel_R(dir_idx(1)))) & + /(rho_L*(s_L - vel_L(dir_idx(1))) - & + rho_R*(s_R - vel_R(dir_idx(1)))) + elseif (wave_speeds == 2) then + pres_SL = 5e-1_wp*(pres_L + pres_R + rho_avg*c_avg* & + (vel_L(dir_idx(1)) - & + vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + Ms_L = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_L)/(1._wp + gamma_L))* & + (pres_SL/pres_L - 1._wp)*pres_L/ & + ((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, sqrt(1._wp + ((5e-1_wp + gamma_R)/(1._wp + gamma_R))* & + (pres_SR/pres_R - 1._wp)*pres_R/ & + ((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & + (pres_L - pres_R)/ & + (rho_avg*c_avg)) + end if + + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + xi_M = (5e-1_wp + sign(5e-1_wp, s_L)) & + + (5e-1_wp - sign(5e-1_wp, s_L)) & + *(5e-1_wp + sign(5e-1_wp, s_R)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_R)) & + + (5e-1_wp - sign(5e-1_wp, s_L)) & + *(5e-1_wp + sign(5e-1_wp, s_R)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! Mass + if (.not. relativity) then + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*alpha_rho_R(i)*vel_R(norm_dir) & + - s_P*alpha_rho_L(i)*vel_L(norm_dir) & + + s_M*s_P*(alpha_rho_L(i) & + - alpha_rho_R(i))) & + /(s_M - s_P) + end do + elseif (relativity) then + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) & + - s_P*Ga%L*alpha_rho_L(i)*vel_L(norm_dir) & + + s_M*s_P*(Ga%L*alpha_rho_L(i) & + - Ga%R*alpha_rho_R(i))) & + /(s_M - s_P) + end do + end if + + ! Momentum + if (mhd .and. (.not. relativity)) then + ! Flux of rho*v_x in the ${XYZ}$ direction + ! = rho * v_x * v_${XYZ}$ - B_x * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(rho_R*vel_R(1)*vel_R(norm_dir) & + - B%R(1)*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(1)*vel_L(norm_dir) & + - B%L(1)*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(1) - rho_R*vel_R(1))) & + /(s_M - s_P) + ! Flux of rho*v_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(rho_R*vel_R(2)*vel_R(norm_dir) & + - B%R(2)*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(2)*vel_L(norm_dir) & + - B%L(2)*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(2) - rho_R*vel_R(2))) & + /(s_M - s_P) + ! Flux of rho*v_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(rho_R*vel_R(3)*vel_R(norm_dir) & + - B%R(3)*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(rho_L*vel_L(3)*vel_L(norm_dir) & + - B%L(3)*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(rho_L*vel_L(3) - rho_R*vel_R(3))) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! Flux of m_x in the ${XYZ}$ direction + ! = m_x * v_${XYZ}$ - b_x/Gamma * B_${XYZ}$ + delta_(${XYZ}$,x) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 1) = & + (s_M*(cm%R(1)*vel_R(norm_dir) & + - b4%R(1)/Ga%R*B%R(norm_dir) & + + dir_flg(1)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(1)*vel_L(norm_dir) & + - b4%L(1)/Ga%L*B%L(norm_dir) & + + dir_flg(1)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(1) - cm%R(1))) & + /(s_M - s_P) + ! Flux of m_y in the ${XYZ}$ direction + ! = rho * v_y * v_${XYZ}$ - B_y * B_${XYZ}$ + delta_(${XYZ}$,y) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + (s_M*(cm%R(2)*vel_R(norm_dir) & + - b4%R(2)/Ga%R*B%R(norm_dir) & + + dir_flg(2)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(2)*vel_L(norm_dir) & + - b4%L(2)/Ga%L*B%L(norm_dir) & + + dir_flg(2)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(2) - cm%R(2))) & + /(s_M - s_P) + ! Flux of m_z in the ${XYZ}$ direction + ! = rho * v_z * v_${XYZ}$ - B_z * B_${XYZ}$ + delta_(${XYZ}$,z) * p_tot + flux_rs${XYZ}$_vf(j, k, l, contxe + 3) = & + (s_M*(cm%R(3)*vel_R(norm_dir) & + - b4%R(3)/Ga%R*B%R(norm_dir) & + + dir_flg(3)*(pres_R + pres_mag%R)) & + - s_P*(cm%L(3)*vel_L(norm_dir) & + - b4%L(3)/Ga%L*B%L(norm_dir) & + + dir_flg(3)*(pres_L + pres_mag%L)) & + + s_M*s_P*(cm%L(3) - cm%R(3))) & + /(s_M - s_P) + elseif (bubbles_euler) then + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + else if (hypoelasticity) then + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_R & + - tau_e_R(dir_idx_tau(i))) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_L & + - tau_e_L(dir_idx_tau(i))) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) + end do + else + !$acc loop seq + do i = 1, num_vels + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *vel_R(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_R) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *vel_L(dir_idx(i)) & + + dir_flg(dir_idx(i))*pres_L) & + + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + - rho_R*vel_R(dir_idx(i)))) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + end if + + ! Energy + if (mhd .and. (.not. relativity)) then + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir)*(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) & + - s_P*(vel_L(norm_dir)*(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3))) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + elseif (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux + ! Hard-coded for single-component for now + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) + else if (bubbles_euler) then + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + else if (hypoelasticity) then + flux_tau_L = 0._wp; flux_tau_R = 0._wp + !$acc loop seq + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) & + + s_M*s_P*(E_L - E_R))/(s_M - s_P) + else + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + (s_M*vel_R(dir_idx(1))*(E_R + pres_R) & + - s_P*vel_L(dir_idx(1))*(E_L + pres_L) & + + s_M*s_P*(E_L - E_R)) & + /(s_M - s_P) & + + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms - vel_L_rms)/2._wp + end if + + ! Elastic Stresses + if (hypoelasticity) then + do i = 1, strxe - strxb + 1 !TODO: this indexing may be slow + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + (s_M*(rho_R*vel_R(dir_idx(1)) & + *tau_e_R(i)) & + - s_P*(rho_L*vel_L(dir_idx(1)) & + *tau_e_L(i)) & + + s_M*s_P*(rho_L*tau_e_L(i) & + - rho_R*tau_e_R(i))) & + /(s_M - s_P) + end do + end if + + ! Advection + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + (qL_prim_rs${XYZ}$_vf(j, k, l, i) & + - qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) & + *s_M*s_P/(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = & + (s_M*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + - s_P*qL_prim_rs${XYZ}$_vf(j, k, l, i)) & + /(s_M - s_P) + end do + + ! Xi field + !if ( hyperelasticity ) then + ! do i = 1, num_dims + ! flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + ! (s_M*rho_R*vel_R(dir_idx(1))*xi_field_R(i) & + ! - s_P*rho_L*vel_L(dir_idx(1))*xi_field_L(i) & + ! + s_M*s_P*(rho_L*xi_field_L(i) & + ! - rho_R*xi_field_R(i))) & + ! /(s_M - s_P) + ! end do + !end if + + ! Div(U)? + !$acc loop seq + do i = 1, num_vels + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & + (xi_M*(rho_L*vel_L(dir_idx(i))* & + (s_L - vel_L(dir_idx(1))) - & + pres_L*dir_flg(dir_idx(i))) - & + xi_P*(rho_R*vel_R(dir_idx(i))* & + (s_R - vel_R(dir_idx(1))) - & + pres_R*dir_flg(dir_idx(i)))) & + /(xi_M*rho_L*(s_L - vel_L(dir_idx(1))) - & + xi_P*rho_R*(s_R - vel_R(dir_idx(1)))) + end do + + if (bubbles_euler) then + ! From HLLC: Kills mass transport @ bubble gas density + if (num_fluids > 1) then + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp + end if + end if + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + + flux_rs${XYZ}$_vf(j, k, l, i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) & + - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + + s_M*s_P*(Y_L*rho_L - Y_R*rho_R)) & + /(s_M - s_P) + flux_src_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + + if (mhd) then + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 + ! B_z flux = v_x * B_z - v_z * Bx0 + !acc loop seq + do i = 0, 1 + flux_rsx_vf(j, k, l, B_idx%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) & + + s_M*s_P*(B%L(2 + i) - B%R(2 + i)))/(s_M - s_P) + end do + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) + ! B_y d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) + ! B_z d/d${XYZ}$ flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + !$acc loop seq + do i = 0, 2 + flux_rs${XYZ}$_vf(j, k, l, B_idx%beg + i) = (1 - dir_flg(i + 1))*( & + s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1)*B%R(norm_dir)) - & + s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1)*B%L(norm_dir)) + & + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + end do + end if + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp + end if + + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + 2) & + - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + end if + + if (cyl_coord .and. hypoelasticity) then + ! += tau_sigmasigma using HLL + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + 2) + & + (s_M*tau_e_R(4) - s_P*tau_e_L(4)) & + /(s_M - s_P) + + !$acc loop seq + do i = strxb, strxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + end if + #:endif + end do + end do + end do + end if + + #:endfor + + if (viscous) then + if (weno_Re_flux) then + + call s_compute_viscous_source_flux( & + qL_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + qR_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux( & + q_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + q_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + end if + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir) + + end subroutine s_hll_riemann_solver + + !> This procedure is the implementation of the Harten, Lax, + !! van Leer, and contact (HLLC) approximate Riemann solver, + !! see Toro (1999) and Johnsen (2007). The viscous and the + !! surface tension effects have been included by modifying + !! the exact Riemann solver of Perigaud and Saurel (2005). + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), & + allocatable, dimension(:), & + intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp) :: rho_L, rho_R + real(wp), dimension(num_dims) :: vel_L, vel_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps + real(wp) :: T_L, T_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: Y_L, Y_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(2) :: Re_L, Re_R + + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_L, xi_R !< Left and right wave speeds functions + real(wp) :: xi_M, xi_P + real(wp) :: xi_MP, xi_PP + + real(wp) :: nbub_L, nbub_R + real(wp), dimension(nb) :: R0_L, R0_R + real(wp), dimension(nb) :: V0_L, V0_R + real(wp), dimension(nb) :: P0_L, P0_R + real(wp), dimension(nb) :: pbw_L, pbw_R + real(wp) :: ptilde_L, ptilde_R + + real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom + + real(wp) :: PbwR3Lbar, Pbwr3Rbar + real(wp) :: R3Lbar, R3Rbar + real(wp) :: R3V2Lbar, R3V2Rbar + + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp), dimension(num_dims) :: xi_field_L, xi_field_R + real(wp) :: G_L, G_R + + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + real(wp) :: flux_ene_e + real(wp) :: zcoef, pcorr !< low Mach number correction + + integer :: i, j, k, l, q !< Generic loop iterators + integer :: idx1, idxi + type(riemann_states) :: c_fast, vel + integer :: loop_end + + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + + call s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 + + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + + if (norm_dir == ${NORM_DIR}$) then + + ! 6-EQUATION MODEL WITH HLLC + if (model_eqns == 3) then + !ME3 + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(vel_L, vel_R, vel_K_Star, Re_L, Re_R, rho_avg, h_avg, gamma_avg, & + !$acc s_L, s_R, s_S, vel_avg_rms, alpha_L, alpha_R, Ys_L, Ys_R, Xs_L, Xs_R, & + !$acc Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, & + !$acc tau_e_L, tau_e_R, G_L, G_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, & + !$acc zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + idx1 = dir_idx(1) + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + end do + + !$acc loop seq + do i = 1, num_fluids + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, advxb + i - 1) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, advxb + i - 1) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if + end if + end do + end if + + ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp; G_R = 0_wp; + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + ! COMPUTING THE DIRECT WAVE SPEEDS + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(idx1))/(s_L - s_S) + xi_R = (s_R - vel_R(idx1))/(s_R - s_S) + + ! goes with numerical star velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(0.5_wp, s_S)) + xi_P = (5e-1_wp - sign(0.5_wp, s_S)) + + ! goes with the numerical velocity in x/y/z directions + ! xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) + xi_MP = -min(0._wp, sign(1._wp, s_L)) + xi_PP = max(0._wp, sign(1._wp, s_R)) + + E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & + (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) - E_L)) + & + xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & + (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) + p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) + & + xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) + + rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + & + xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) + + vel_K_Star = vel_L(idx1)*(1_wp - xi_MP) + xi_MP*vel_R(idx1) + & + xi_MP*xi_PP*(s_S - vel_R(idx1)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING FLUXES + ! MASS FLUX. + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*(vel_L(idx1) + s_M*(xi_L - 1._wp)) + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! MOMENTUM FLUX. + ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = rho_Star*vel_K_Star* & + (dir_flg(idxi)*vel_K_Star + (1_wp - dir_flg(idxi))*(xi_M*vel_L(idxi) + xi_P*vel_R(idxi))) + dir_flg(idxi)*p_Star & + + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr + end do + + ! ENERGY FLUX. + ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = (E_star + p_Star)*vel_K_Star & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0_wp; + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + ! MOMENTUM ELASTIC FLUX. + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & + - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - & + xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & + xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & + s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e + end if + + ! VOLUME FRACTION FLUX. + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i)*s_S + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*s_S + end do + + ! SOURCE TERM FOR VOLUME FRACTION ADVECTION FLUX. + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & + xi_M*(vel_L(idxi) + dir_flg(idxi)*(s_S*(xi_MP*(xi_L - 1) + 1) - vel_L(idxi))) + & + xi_P*(vel_R(idxi) + dir_flg(idxi)*(s_S*(xi_PP*(xi_R - 1) + 1) - vel_R(idxi))) + end do + + ! INTERNAL ENERGIES ADVECTION FLUX. + ! K-th pressure and velocity in preparation for the internal energy flux + !$acc loop seq + do i = 1, num_fluids + p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1_wp + gammas(i)))* & + xi_L**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_L) + pres_L) + & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1_wp + gammas(i)))* & + xi_R**(1_wp/gammas(i) + 1_wp) - pi_infs(i)/(1_wp + gammas(i)) - pres_R) + pres_R) + + flux_rs${XYZ}$_vf(j, k, l, i + intxb - 1) = & + ((xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1))* & + (gammas(i)*p_K_Star + pi_infs(i)) + & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + contxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + contxb - 1))* & + qvs(i))*vel_K_Star & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S*(xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i + advxb - 1) + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i + advxb - 1)) + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) + end do + end if + + ! REFERENCE MAP FLUX. + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + - rho_L*vel_L(idx1)*xi_field_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & + - rho_R*vel_R(idx1)*xi_field_R(i)) + end do + end if + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rs${XYZ}$_vf(j, k, l, c_idx) = & + (xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) + & + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx))*s_S + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + !$acc loop seq + do i = intxb, intxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0_wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) = & + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb - 1 + dir_idx(1)) - p_Star + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end do + end do + end do + + elseif (model_eqns == 4) then + !ME4 + !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & + !$acc rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, vel_avg_rms, nbub_L, nbub_R, ptilde_L, ptilde_R) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + ! Initialize all variables + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; + !$acc loop seq + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + rho_L = rho_L + alpha_rho_L(i) + rho_R = rho_R + alpha_rho_R(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + qv_L + + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) + xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*alpha_rho_L(i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*alpha_rho_R(i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Momentum flux. + ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(i)) + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & + dir_flg(dir_idx(i))*pres_L) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(i)) + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & + dir_flg(dir_idx(i))*pres_R) + if (bubbles_euler) then + ! Put p_tilde in + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) - & + dir_flg(dir_idx(i))*(xi_M*ptilde_L + xi_P*ptilde_R) + end if + end do + + flux_rs${XYZ}$_vf(j, k, l, E_idx) = 0._wp + + !$acc loop seq + do i = alf_idx, alf_idx !only advect the void fraction + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Source for volume fraction advection equation + !$acc loop seq + do i = 1, num_dims + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = 0._wp + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) + + ! Add advection flux for bubble variables + if (bubbles_euler) then + !$acc loop seq + do i = bubxb, bubxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + end if + + ! Geometrical source flux for cylindrical coordinates + + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + end if + #:endif + end do + end do + end do + !$acc end parallel loop + + elseif (model_eqns == 2 .and. bubbles_euler) then + !$acc parallel loop collapse(3) gang vector default(present) private(R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, vel_R, & + !$acc rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, s_L, s_R, s_S, nbub_L, nbub_R, ptilde_L, ptilde_R, vel_avg_rms, Re_L, Re_R, pcorr, zcoef, vel_L_tmp, vel_R_tmp) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + ! Initialize all variables + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp; + gamma_L = 0._wp; gamma_R = 0._wp; + pi_inf_L = 0._wp; pi_inf_R = 0._wp; + qv_L = 0._wp; qv_R = 0._wp; + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_dims + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + loop_end = num_fluids + if (.not. mpp_lim .and. num_fluids > 2) loop_end = num_fluids - 1 + + ! Retain this in the refactor + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, loop_end + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + end do + else + rho_L = qL_prim_rs${XYZ}$_vf(j, k, l, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) + end if + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + if (mpp_lim .and. (num_fluids > 2)) then + !$acc loop seq + do i = 1, num_fluids + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else if (num_fluids > 2) then + !$acc loop seq + do i = 1, num_fluids - 1 + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + else + rho_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, 1) + gamma_R = gammas(1) + pi_inf_R = pi_infs(1) + qv_R = qvs(1) + end if + + if (viscous) then + if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = (1._wp - qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_R(i) = (1._wp - qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q)))/Res(i, q) & + + Re_R(i) + end do + + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + end if + + E_L = gamma_L*pres_L + pi_inf_L + 5e-1_wp*rho_L*vel_L_rms + + E_R = gamma_R*pres_R + pi_inf_R + 5e-1_wp*rho_R*vel_R_rms + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + if (avg_state == 2) then + !$acc loop seq + do i = 1, nb + R0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, rs(i)) + R0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, rs(i)) + + V0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, vs(i)) + V0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, vs(i)) + if (.not. polytropic .and. .not. qbmm) then + P0_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, ps(i)) + P0_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, ps(i)) + end if + end do + + if (.not. qbmm) then + if (adv_n) then + nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, n_idx) + nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, n_idx) + else + nbub_L_denom = 0._wp + nbub_R_denom = 0._wp + !$acc loop seq + do i = 1, nb + nbub_L_denom = nbub_L_denom + (R0_L(i)**3._wp)*weight(i) + nbub_R_denom = nbub_R_denom + (R0_R(i)**3._wp)*weight(i) + end do + nbub_L = (3._wp/(4._wp*pi))*qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)/nbub_L_denom + nbub_R = (3._wp/(4._wp*pi))*qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom + end if + else + !nb stored in 0th moment of first R0 bin in variable conversion module + nbub_L = qL_prim_rs${XYZ}$_vf(j, k, l, bubxb) + nbub_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, bubxb) + end if + + !$acc loop seq + do i = 1, nb + if (.not. qbmm) then + if (polytropic) then + pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), 0._wp) + pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0._wp) + else + pbw_L(i) = f_cpbw_KM(R0(i), R0_L(i), V0_L(i), P0_L(i)) + pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), P0_R(i)) + end if + end if + end do + + if (qbmm) then + PbwR3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 4) + PbwR3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 4) + + R3Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 1) + R3Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 1) + + R3V2Lbar = mom_sp_rs${XYZ}$_vf(j, k, l, 3) + R3V2Rbar = mom_sp_rs${XYZ}$_vf(j + 1, k, l, 3) + else + + PbwR3Lbar = 0._wp + PbwR3Rbar = 0._wp + + R3Lbar = 0._wp + R3Rbar = 0._wp + + R3V2Lbar = 0._wp + R3V2Rbar = 0._wp + + !$acc loop seq + do i = 1, nb + PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) + PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) + + R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) + R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) + + R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) + R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) + end do + end if + + if (qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf) then + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*pres_L + else + ptilde_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - & + rho_L*R3V2Lbar/R3Lbar) + end if + + if (qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar < small_alf) then + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*pres_R + else + ptilde_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - & + rho_R*R3V2Rbar/R3Rbar) + end if + + if ((ptilde_L /= ptilde_L) .or. (ptilde_R /= ptilde_R)) then + end if + + rho_avg = 5e-1_wp*(rho_L + rho_R) + H_avg = 5e-1_wp*(H_L + H_R) + gamma_avg = 5e-1_wp*(gamma_L + gamma_R) + vel_avg_rms = 0._wp + + !$acc loop seq + do i = 1, num_dims + vel_avg_rms = vel_avg_rms + (5e-1_wp*(vel_L(i) + vel_R(i)))**2._wp + end do + + end if + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, 0._wp, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) + xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + if (bubbles_euler .and. (num_fluids > 1)) then + ! Kill mass transport @ gas density + flux_rs${XYZ}$_vf(j, k, l, contxe) = 0._wp + end if + + ! Momentum flux. + ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + + ! Include p_tilde + + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(i)) + & + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + & + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(i)) + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + & + (1._wp - dir_flg(dir_idx(i)))* & + vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) & + + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + end do + + ! Energy flux. + ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + xi_M*(vel_L(dir_idx(1))*(E_L + pres_L - ptilde_L) + & + s_M*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & + (rho_L*s_S + (pres_L - ptilde_L)/ & + (s_L - vel_L(dir_idx(1))))) - E_L)) & + + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) + & + s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & + (rho_R*s_S + (pres_R - ptilde_R)/ & + (s_R - vel_R(dir_idx(1))))) - E_R)) & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! Volume fraction flux + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + ! Source for volume fraction advection equation + !$acc loop seq + do i = 1, num_dims + vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(i)) = & + xi_M*(vel_L(dir_idx(i)) + & + dir_flg(dir_idx(i))* & + s_M*(xi_L - 1._wp)) & + + xi_P*(vel_R(dir_idx(i)) + & + dir_flg(dir_idx(i))* & + s_P*(xi_R - 1._wp)) + + !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(idxi)%sf(j,k,l) = 0._wp + end do + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, dir_idx(1)) + + ! Add advection flux for bubble variables + !$acc loop seq + do i = bubxb, bubxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*nbub_L*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end do + + if (qbmm) then + flux_rs${XYZ}$_vf(j, k, l, bubxb) = & + xi_M*nbub_L & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end if + + if (adv_n) then + flux_rs${XYZ}$_vf(j, k, l, n_idx) = & + xi_M*nbub_L & + *(vel_L(dir_idx(1)) + s_M*(xi_L - 1._wp)) & + + xi_P*nbub_R & + *(vel_R(dir_idx(1)) + s_P*(xi_R - 1._wp)) + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(1)) = & + xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + + xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(dir_idx(1))* & + vel_L(dir_idx(1)) + & + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + - xi_P*(rho_R*(vel_R(dir_idx(1))* & + vel_R(dir_idx(1)) + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + & + (1._wp - dir_flg(dir_idx(1)))* & + vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif + end do + end do + end do + !$acc end parallel loop + else + ! 5-EQUATION MODEL WITH HLLC + !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R, & + !$acc rho_avg, h_avg, gamma_avg, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & + !$acc vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & + !$acc tau_e_L, tau_e_R, xi_field_L, xi_field_R, & + !$acc Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2) copyin(is1,is2,is3) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + !idx1 = 1; if (dir_idx(1) == 2) idx1 = 2; if (dir_idx(1) == 3) idx1 = 3 + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + alpha_L_sum = 0._wp; alpha_R_sum = 0._wp + + !$acc loop seq + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + vel_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + i) + vel_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + ! Change this by splitting it into the cases + ! present in the bubbles_euler + if (mpp_lim) then + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, i) = max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, i)) + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = min(max(0._wp, qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)/max(alpha_L_sum, sgm_eps) + end do + + !$acc loop seq + do i = 1, num_fluids + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) = max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)) + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = min(max(0._wp, qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)), 1._wp) + alpha_R_sum = alpha_R_sum + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + !$acc loop seq + do i = 1, num_fluids + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + !$acc loop seq + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rs${XYZ}$_vf(j, k, l, i) + gamma_L = gamma_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rs${XYZ}$_vf(j, k, l, i)*qvs(i) + rho_R = rho_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + gamma_R = gamma_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rs${XYZ}$_vf(j + 1, k, l, i)*qvs(i) + end do + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_L(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_L(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + + end do + + !$acc loop seq + do i = 1, 2 + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_R(i) = 0._wp + + !$acc loop seq + do q = 1, Re_size(i) + Re_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i, q) & + + Re_R(i) + end do + + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + c_sum_Yi_Phi = 0.0_wp + !$acc loop seq + do i = chemxb, chemxe + Ys_L(i - chemxb + 1) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Ys_R(i - chemxb + 1) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + else + E_L = gamma_L*pres_L + pi_inf_L + 5e-1*rho_L*vel_L_rms + qv_L + + E_R = gamma_R*pres_R + pi_inf_R + 5e-1*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + G_L = 0_wp + G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + !$acc loop seq + do i = 1, strxe - strxb + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4_wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4_wp*G_R) + end if + end if + end do + end if + + ! ENERGY ADJUSTMENTS FOR HYPERELASTIC ENERGY + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + xi_field_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) + xi_field_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, xibeg - 1 + i) + end do + G_L = 0_wp + G_R = 0_wp + !$acc loop seq + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs(i) + G_R = G_R + alpha_R(i)*Gs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rs${XYZ}$_vf(j, k, l, xiend + 1) + E_R = E_R + G_R*qR_prim_rs${XYZ}$_vf(j + 1, k, l, xiend + 1) + end if + !$acc loop seq + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) + tau_e_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, strxb - 1 + i) + end do + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, & + vel_L_rms, 0._wp, c_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, & + vel_R_rms, 0._wp, c_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, & + vel_avg_rms, c_sum_Yi_Phi, c_avg) + + if (viscous) then + !$acc loop seq + do i = 1, 2 + Re_avg_rs${XYZ}$_vf(j, k, l, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + call s_compute_wave_speed(wave_speeds, vel_L, vel_R, pres_L, pres_R, rho_L, rho_R, rho_avg, & + c_L, c_R, c_avg, c_fast%L, c_fast%R, G_L, G_R, & + tau_e_L, tau_e_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, & + s_L, s_R, s_S, s_M, s_P, dir_idx(1), dir_idx_tau(1)) + + ! goes with q_star_L/R = xi_L/R * (variable) + ! xi_L/R = ( ( s_L/R - u_L/R )/(s_L/R - s_star) ) + xi_L = (s_L - vel_L(idx1))/(s_L - s_S) + xi_R = (s_R - vel_R(idx1))/(s_R - s_S) + + ! goes with numerical velocity in x/y/z directions + ! xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5e-1_wp + sign(5e-1_wp, s_S)) + xi_P = (5e-1_wp - sign(5e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING THE HLLC FLUXES + ! MASS FLUX. + !$acc loop seq + do i = 1, contxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! MOMENTUM FLUX. + ! f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idxi) + & + s_M*(xi_L*(dir_flg(idxi)*s_S + & + (1._wp - dir_flg(idxi))* & + vel_L(idxi)) - vel_L(idxi))) + & + dir_flg(idxi)*(pres_L)) & + + xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idxi) + & + s_P*(xi_R*(dir_flg(idxi)*s_S + & + (1._wp - dir_flg(idxi))* & + vel_R(idxi)) - vel_R(idxi))) + & + dir_flg(idxi)*(pres_R)) & + + (s_M/s_L)*(s_P/s_R)*dir_flg(idxi)*pcorr + end do + + ! ENERGY FLUX. + ! f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rs${XYZ}$_vf(j, k, l, E_idx) = & + xi_M*(vel_L(idx1)*(E_L + pres_L) + & + s_M*(xi_L*(E_L + (s_S - vel_L(idx1))* & + (rho_L*s_S + pres_L/ & + (s_L - vel_L(idx1)))) - E_L)) & + + xi_P*(vel_R(idx1)*(E_R + pres_R) + & + s_P*(xi_R*(E_R + (s_S - vel_R(idx1))* & + (rho_R*s_S + pres_R/ & + (s_R - vel_R(idx1)))) - E_R)) & + + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0_wp + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + ! MOMENTUM ELASTIC FLUX. + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) = & + flux_rs${XYZ}$_vf(j, k, l, contxe + idxi) & + - xi_M*tau_e_L(dir_idx_tau(i)) - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - & + xi_M*(vel_L(idxi)*tau_e_L(dir_idx_tau(i)) + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i))/(s_L - vel_L(i)))))) - & + xi_P*(vel_R(idxi)*tau_e_R(dir_idx_tau(i)) + & + s_P*(xi_R*((s_S - vel_R(i))*(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rs${XYZ}$_vf(j, k, l, E_idx) = flux_rs${XYZ}$_vf(j, k, l, E_idx) + flux_ene_e + end if + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + !$acc loop seq + do i = 1, strxe - strxb + 1 + flux_rs${XYZ}$_vf(j, k, l, strxb - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) - rho_L*vel_L(idx1)*tau_e_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(idx1)*tau_e_R(i)) + end do + end if + + ! VOLUME FRACTION FLUX. + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, i) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end do + + ! VOLUME FRACTION SOURCE FLUX. + !$acc loop seq + do i = 1, num_dims + idxi = dir_idx(i) + vel_src_rs${XYZ}$_vf(j, k, l, idxi) = & + xi_M*(vel_L(idxi) + & + dir_flg(idxi)* & + s_M*(xi_L - 1._wp)) & + + xi_P*(vel_R(idxi) + & + dir_flg(idxi)* & + s_P*(xi_R - 1._wp)) + end do + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rs${XYZ}$_vf(j, k, l, c_idx) = & + xi_M*qL_prim_rs${XYZ}$_vf(j, k, l, c_idx) & + *(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*qR_prim_rs${XYZ}$_vf(j + 1, k, l, c_idx) & + *(vel_R(idx1) + s_P*(xi_R - 1._wp)) + end if + + ! REFERENCE MAP FLUX. + if (hyperelasticity) then + !$acc loop seq + do i = 1, num_dims + flux_rs${XYZ}$_vf(j, k, l, xibeg - 1 + i) = & + xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + - rho_L*vel_L(idx1)*xi_field_L(i)) + & + xi_P*(s_S/(s_R - s_S))*(s_R*rho_R*xi_field_R(i) & + - rho_R*vel_R(idx1)*xi_field_R(i)) + end do + end if + + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = vel_src_rs${XYZ}$_vf(j, k, l, idx1) + + if (chemistry) then + !$acc loop seq + do i = chemxb, chemxe + Y_L = qL_prim_rs${XYZ}$_vf(j, k, l, i) + Y_R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + + flux_rs${XYZ}$_vf(j, k, l, i) = xi_M*rho_L*Y_L*(vel_L(idx1) + s_M*(xi_L - 1._wp)) & + + xi_P*rho_R*Y_R*(vel_R(idx1) + s_P*(xi_R - 1._wp)) + flux_src_rs${XYZ}$_vf(j, k, l, i) = 0.0_wp + end do + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + !Substituting the advective flux into the inviscid geometrical source flux + !$acc loop seq + do i = 1, E_idx + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = flux_rs${XYZ}$_vf(j, k, l, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rs${XYZ}$_vf(j, k, l, contxe + idx1) = & + xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + + xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + ! Geometrical source of the void fraction(s) is zero + !$acc loop seq + do i = advxb, advxe + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + !$acc loop seq + do i = 1, sys_size + flux_gsrc_rs${XYZ}$_vf(j, k, l, i) = 0._wp + end do + + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxb + 1) = & + -xi_M*(rho_L*(vel_L(idx1)* & + vel_L(idx1) + & + s_M*(xi_L*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_L(idx1)) - vel_L(idx1)))) & + - xi_P*(rho_R*(vel_R(idx1)* & + vel_R(idx1) + & + s_P*(xi_R*(dir_flg(idx1)*s_S + & + (1._wp - dir_flg(idx1))* & + vel_R(idx1)) - vel_R(idx1)))) + flux_gsrc_rs${XYZ}$_vf(j, k, l, momxe) = flux_rs${XYZ}$_vf(j, k, l, momxb + 1) + + end if + #:endif + end do + end do + end do + !$acc end parallel loop + end if + end if + #:endfor + ! Computing HLLC flux and source flux for Euler system of equations + + if (viscous) then + if (weno_Re_flux) then + call s_compute_viscous_source_flux( & + qL_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + qR_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux( & + q_prim_vf(momxb:momxe), & + dqL_prim_dx_vf(momxb:momxe), & + dqL_prim_dy_vf(momxb:momxe), & + dqL_prim_dz_vf(momxb:momxe), & + q_prim_vf(momxb:momxe), & + dqR_prim_dx_vf(momxb:momxe), & + dqR_prim_dy_vf(momxb:momxe), & + dqR_prim_dz_vf(momxb:momxe), & + flux_src_vf, norm_dir, ix, iy, iz) + end if + end if + + if (surface_tension) then + call s_compute_capilary_source_flux( & + q_prim_vf, & + vel_src_rsx_vf, & + vel_src_rsy_vf, & + vel_src_rsz_vf, & + flux_src_vf, & + norm_dir, isx, isy, isz) + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir) + + end subroutine s_hllc_riemann_solver + + !> HLLD Riemann solver resolves 5 of the 7 waves of MHD equations: + !! 1 entropy wave, 2 Alfvén waves, 2 fast magnetosonic waves. + subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_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) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables: + real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R + type(riemann_states_vec3) :: vel + type(riemann_states) :: rho, pres, E, H_no_mag + type(riemann_states) :: gamma, pi_inf, qv + type(riemann_states) :: vel_rms + + type(riemann_states_vec3) :: B + type(riemann_states) :: c, c_fast, pres_mag + + ! HLLD speeds and intermediate state variables: + real(wp) :: s_L, s_R, s_M, s_starL, s_starR + real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR + + real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR + real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld + + ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) + ! Note: vel and B are permutated, so vel(1) is the normal velocity, and x is the normal direction + ! Note: Bx is omitted as the magnetic flux is always zero in the normal direction + + real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx + real(wp) :: vL_star, vR_star, wL_star, wR_star + real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double + + integer :: i, j, k, l + + call s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, dqL_prim_dz_vf, qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, & + norm_dir, ix, iy, iz) + + call s_initialize_riemann_solver( & + q_prim_vf, flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + #:for NORM_DIR, XYZ in [(1, 'x'), (2, 'y'), (3, 'z')] + if (norm_dir == ${NORM_DIR}$) then + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, & + !$acc rho, pres, E, H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, & + !$acc U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + + ! (1) Extract the left/right primitive states + do i = 1, contxe + alpha_rho_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, i) + alpha_rho_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, i) + end do + + ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic + do i = 1, num_vels + vel%L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, contxe + dir_idx(i)) + vel%R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, contxe + dir_idx(i)) + end do + + vel_rms%L = sum(vel%L**2._wp) + vel_rms%R = sum(vel%R**2._wp) + + do i = 1, num_fluids + alpha_L(i) = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx + i) + alpha_R(i) = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx + i) + end do + + pres%L = qL_prim_rs${XYZ}$_vf(j, k, l, E_idx) + pres%R = qR_prim_rs${XYZ}$_vf(j + 1, k, l, E_idx) + + ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated + B%L = [Bx0, qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg), qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + 1)] + B%R = [Bx0, qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg), qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + 1)] + else ! 2D/3D: Bx, By, Bz as variables + B%L = [qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(1) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(2) - 1), & + qL_prim_rs${XYZ}$_vf(j, k, l, B_idx%beg + dir_idx(3) - 1)] + B%R = [qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(1) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(2) - 1), & + qR_prim_rs${XYZ}$_vf(j + 1, k, l, B_idx%beg + dir_idx(3) - 1)] + end if + end if + + ! Sum properties of all fluid components + rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp + rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp + !$acc loop seq + do i = 1, num_fluids + rho%L = rho%L + alpha_rho_L(i) + gamma%L = gamma%L + alpha_L(i)*gammas(i) + pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) + qv%L = qv%L + alpha_rho_L(i)*qvs(i) + + rho%R = rho%R + alpha_rho_R(i) + gamma%R = gamma%R + alpha_R(i)*gammas(i) + pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) + qv%R = qv%R + alpha_rho_R(i)*qvs(i) + end do + + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L + E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy + H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L + H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + + ! (2) Compute fast wave speeds + call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, 0._wp, c%L) + call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, 0._wp, c%R) + call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) + call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) + + ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] + s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) + s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) + + pTot_L = pres%L + pres_mag%L + pTot_R = pres%R + pres_mag%R + + s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - & + (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/ & + ((s_R - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) + + ! (4) Compute star state variables + rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) + rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) + p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) + E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) + E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) + + ! (5) Compute left/right state vectors and fluxes + U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] + U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] + U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] + U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] + + F_L(1) = U_L(2) + F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L + F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) + F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) + F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + + F_R(1) = U_R(2) + F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R + F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) + F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) + F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) + ! Compute the star flux using HLL relation + F_starL = F_L + s_M*(U_starL - U_L) + F_starR = F_R + s_M*(U_starR - U_R) + ! Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! Compute the double–star states [Miyoshi Eqns. (59)-(62)] + sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) + vL_star = vel%L(2); wL_star = vel%L(3) + vR_star = vel%R(2); wR_star = vel%R(3) + + ! (6) Compute the double–star states [Miyoshi Eqns. (59)-(62)] + denom_ds = sqrt_rhoL_star + sqrt_rhoR_star + sign_Bx = sign(1._wp, B%L(1)) + v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds + w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds + By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star - vL_star)*sign_Bx)/denom_ds + Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star - wL_star)*sign_Bx)/denom_ds + + E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx + E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double + w_double*Bz_double))*sign_Bx + E_double = 0.5_wp*(E_doubleL + E_doubleR) + + U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, E_double] + U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*w_double, rhoR_star*w_double, By_double, Bz_double, E_double] + + ! (7) Compute the rotational (Alfvén) speeds + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + + ! (8) Choose HLLD flux based on wave-speed regions + if (0.0_wp <= s_L) then + F_hlld = F_L + else if (0.0_wp <= s_starL) then + F_hlld = F_L + s_L*(U_starL - U_L) + else if (0.0_wp <= s_M) then + F_hlld = F_starL + s_starL*(U_doubleL - U_starL) + else if (0.0_wp <= s_starR) then + F_hlld = F_starR + s_starR*(U_doubleR - U_starR) + else if (0.0_wp <= s_R) then + F_hlld = F_R + s_R*(U_starR - U_R) + else + F_hlld = F_R + end if + + ! (9) Reorder and write temporary variables to the flux array + ! Mass + flux_rs${XYZ}$_vf(j, k, l, 1) = F_hlld(1) ! TODO multi-component + ! Momentum + flux_rs${XYZ}$_vf(j, k, l, [contxe + dir_idx(1), contxe + dir_idx(2), contxe + dir_idx(3)]) = F_hlld([2, 3, 4]) + ! Magnetic field + if (n == 0) then + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg, B_idx%beg + 1]) = F_hlld([5, 6]) + else + flux_rs${XYZ}$_vf(j, k, l, [B_idx%beg + dir_idx(2) - 1, B_idx%beg + dir_idx(3) - 1]) = F_hlld([5, 6]) + end if + ! Energy + flux_rs${XYZ}$_vf(j, k, l, E_idx) = F_hlld(7) + ! Partial fraction + !$acc loop seq + do i = advxb, advxe + flux_rs${XYZ}$_vf(j, k, l, i) = 0._wp ! TODO multi-component (zero for now) + end do + flux_src_rs${XYZ}$_vf(j, k, l, advxb) = 0._wp + end do + end do + end do + !$acc end parallel loop + end if + #:endfor + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, & + norm_dir) + end subroutine s_hlld_riemann_solver + + + !> The computation of parameters, the allocation of memory, + !! the association of pointers and/or the execution of any + !! other procedures that are necessary to setup the module. + impure subroutine s_initialize_riemann_solvers_module + + ! Allocating the variables that will be utilized to formulate the + ! left, right, and average states of the Riemann problem, as well + ! the Riemann problem solution + integer :: i, j + + @:ALLOCATE(Gs(1:num_fluids)) + + do i = 1, num_fluids + Gs(i) = fluid_pp(i)%G + end do + !$acc update device(Gs) + + if (viscous) then + @:ALLOCATE(Res(1:2, 1:maxval(Re_size))) + end if + + if (viscous) then + do i = 1, 2 + do j = 1, Re_size(i) + Res(i, j) = fluid_pp(Re_idx(i, j))%Re(i) + end do + end do + !$acc update device(Res, Re_idx, Re_size) + end if + + !$acc enter data copyin(is1, is2, is3, isx, isy, isz) + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = m; is2%end = n; is3%end = p + + @:ALLOCATE(flux_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + if (qbmm) then + @:ALLOCATE(mom_sp_rsx_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsx_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + if (n == 0) return + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = n; is2%end = m; is3%end = p + + @:ALLOCATE(flux_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + + if (qbmm) then + @:ALLOCATE(mom_sp_rsy_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsy_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + if (p == 0) return + + is1%beg = -1; is2%beg = 0; is3%beg = 0 + is1%end = p; is2%end = n; is3%end = m + + @:ALLOCATE(flux_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_gsrc_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:sys_size)) + @:ALLOCATE(flux_src_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, advxb:sys_size)) + @:ALLOCATE(vel_src_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:num_vels)) + + if (qbmm) then + @:ALLOCATE(mom_sp_rsz_vf(is1%beg:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:4)) + end if + + if (viscous) then + @:ALLOCATE(Re_avg_rsz_vf(is1%beg:is1%end, & + is2%beg:is2%end, & + is3%beg:is3%end, 1:2)) + end if + + end subroutine s_initialize_riemann_solvers_module + + !> The purpose of this subroutine is to populate the buffers + !! of the left and right Riemann states variables, depending + !! on the boundary conditions. + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param dqL_prim_dx_vf The left WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqL_prim_dy_vf The left WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqL_prim_dz_vf The left WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param dqR_prim_dx_vf The right WENO-reconstructed cell-boundary values of the + !! first-order x-dir spatial derivatives + !! @param dqR_prim_dy_vf The right WENO-reconstructed cell-boundary values of the + !! first-order y-dir spatial derivatives + !! @param dqR_prim_dz_vf The right WENO-reconstructed cell-boundary values of the + !! first-order z-dir spatial derivatives + !! @param gm_alphaL_vf Left averaged gradient magnitude + !! @param gm_alphaR_vf Right averaged gradient magnitude + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + subroutine s_populate_riemann_states_variables_buffers( & + qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, dqL_prim_dx_vf, & + dqL_prim_dy_vf, & + dqL_prim_dz_vf, & + qL_prim_vf, & + qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, dqR_prim_dx_vf, & + dqR_prim_dy_vf, & + dqR_prim_dz_vf, & + qR_prim_vf, & + norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:, idwbuff(2)%beg:, idwbuff(3)%beg:, 1:), target, intent(inout) :: qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf + real(wp), dimension(:, :, :, :), pointer :: qL_prim_rs_vf, qR_prim_rs_vf + + type(scalar_field), & + allocatable, dimension(:), & + target, intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, & + dqL_prim_dy_vf, dqR_prim_dy_vf, & + dqL_prim_dz_vf, dqR_prim_dz_vf, & + qL_prim_vf, qR_prim_vf + type(scalar_field), & + dimension(:), & + pointer :: dqL_prim_d_vf, dqR_prim_d_vf + + integer :: end_val, bc_beg, bc_end + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + integer :: i, j, k, l !< Generic loop iterator + + if (norm_dir == 1) then + is1 = ix; is2 = iy; is3 = iz + dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) + bc_beg = bc_x%beg; bc_end = bc_x%end + end_val = m + qL_prim_rs_vf => qL_prim_rsx_vf + qR_prim_rs_vf => qR_prim_rsx_vf + dqL_prim_d_vf => dqL_prim_dx_vf + dqR_prim_d_vf => dqR_prim_dx_vf + else if (norm_dir == 2) then + is1 = iy; is2 = ix; is3 = iz + dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + bc_beg = bc_y%beg; bc_end = bc_y%end + end_val = n + qL_prim_rs_vf => qL_prim_rsy_vf + qR_prim_rs_vf => qR_prim_rsy_vf + dqL_prim_d_vf => dqL_prim_dy_vf + dqR_prim_d_vf => dqR_prim_dy_vf + else + is1 = iz; is2 = iy; is3 = ix + dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + bc_beg = bc_z%beg; bc_end = bc_z%end + end_val = p + qL_prim_rs_vf => qL_prim_rsz_vf + qR_prim_rs_vf => qR_prim_rsz_vf + dqL_prim_d_vf => dqL_prim_dz_vf + dqR_prim_d_vf => dqR_prim_dz_vf + end if + + !$acc update device(is1, is2, is3) + + if (elasticity) then + if (norm_dir == 1) then + dir_idx_tau = (/1, 2, 4/) + else if (norm_dir == 2) then + dir_idx_tau = (/3, 2, 5/) + else + dir_idx_tau = (/6, 4, 5/) + end if + end if + + isx = ix; isy = iy; isz = iz + !$acc update device(isx, isy, isz) ! for stuff in the same module + !$acc update device(dir_idx, dir_flg, dir_idx_tau) ! for stuff in different modules + + ! Population of Buffers in x/y/z-direction + if (bc_beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rs_vf(-1, k, l, i) = qR_prim_rs_vf(0, k, l, i) + end do + end do + end do + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqL_prim_dx_vf(i)%sf(-1, k, l) = dqR_prim_dx_vf(i)%sf(0, k, l) + if (n > 0) then + dqL_prim_dy_vf(i)%sf(-1, k, l) = dqR_prim_dy_vf(i)%sf(0, k, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(-1, k, l) = dqR_prim_dz_vf(i)%sf(0, k, l) + end if + end if + else if (norm_dir == 2) then + dqL_prim_dx_vf(i)%sf(j, -1, l) = dqR_prim_dx_vf(i)%sf(j, 0, l) + dqL_prim_dy_vf(i)%sf(j, -1, l) = dqR_prim_dy_vf(i)%sf(j, 0, l) + if (p > 0) then + dqL_prim_dz_vf(i)%sf(j, -1, l) = dqR_prim_dz_vf(i)%sf(j, 0, l) + end if + else + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end if + end do + end do + end do + end if + end if + + if (bc_end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + !$acc parallel loop collapse(3) gang vector default(present) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rs_vf(end_val + 1, k, l, i) = qL_prim_rs_vf(end_val, k, l, i) + end do + end do + end do + if (viscous) then + !$acc parallel loop collapse(3) gang vector default(present) + do i = momxb, momxe + do l = isz%beg, isz%end + do k = isy%beg, isy%end + if (norm_dir == 1) then + dqR_prim_dx_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dx_vf(i)%sf(end_val, k, l) + if (n > 0) then + dqR_prim_dy_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dy_vf(i)%sf(end_val, k, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(end_val + 1, k, l) = dqL_prim_dz_vf(i)%sf(end_val, k, l) + end if + end if + else if (norm_dir == 2) then + dqR_prim_dx_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dx_vf(i)%sf(j, end_val, l) + dqR_prim_dy_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dy_vf(i)%sf(j, end_val, l) + if (p > 0) then + dqR_prim_dz_vf(i)%sf(j, end_val + 1, l) = dqL_prim_dz_vf(i)%sf(j, end_val, l) + end if + else + dqR_prim_dx_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dx_vf(i)%sf(j, k, end_val) + dqR_prim_dy_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dy_vf(i)%sf(j, k, end_val) + dqR_prim_dz_vf(i)%sf(j, k, end_val + 1) = dqL_prim_dz_vf(i)%sf(j, k, end_val) + end if + end do + end do + end do + end if + end if + ! END: Population of Buffers in z-direction + + end subroutine s_populate_riemann_states_variables_buffers + + !> The computation of parameters, the allocation of memory, + !! the association of pointers and/or the execution of any + !! other procedures needed to configure the chosen Riemann + !! solver algorithm. + !! @param qL_prim_vf The left WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param qR_prim_vf The right WENO-reconstructed cell-boundary values of the + !! cell-average primitive variables + !! @param flux_vf Intra-cell fluxes + !! @param flux_src_vf Intra-cell fluxes sources + !! @param flux_gsrc_vf Intra-cell geometric fluxes sources + !! @param norm_dir Dir. splitting direction + !! @param ix Index bounds in the x-dir + !! @param iy Index bounds in the y-dir + !! @param iz Index bounds in the z-dir + !! @param q_prim_vf Cell-averaged primitive variables + subroutine s_initialize_riemann_solver( & + q_prim_vf, & + flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir, ix, iy, iz) + + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + integer :: i, j, k, l ! Generic loop iterators + + ! Reshaping Inputted Data in x-direction + + if (viscous .or. (surface_tension)) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = momxb, E_idx + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + else if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if + end do + end do + end do + end do + end if + + if (qbmm) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + if (norm_dir == 1) then + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + else if (norm_dir == 2) then + mom_sp_rsy_vf(j, k, l, i) = mom_sp(i)%sf(k, j, l) + else if (norm_dir == 3) then + mom_sp_rsz_vf(j, k, l, i) = mom_sp(i)%sf(l, k, j) + end if + end do + end do + end do + end do + end if + + end subroutine s_initialize_riemann_solver + + !> @brief Computes cylindrical viscous source flux contributions for momentum and energy. + !! Calculates Cartesian components of the stress tensor using averaged velocity derivatives + !! and cylindrical geometric factors, then updates `flux_src_vf`. + !! Assumes x-dir is axial (z_cyl), y-dir is radial (r_cyl), z-dir is azimuthal (theta_cyl for derivatives). + !! @param[in] velL_vf Left boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary $\partial v_i/\partial x$ (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary $\partial v_i/\partial y$ (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary $\partial v_i/\partial z$ (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity ($v_x, v_y, v_z$) (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary $\partial v_i/\partial x$ (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary $\partial v_i/\partial y$ (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary $\partial v_i/\partial z$ (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x-face, 2=y-face, 3=z-face). + !! @param[in] ix Global X-direction loop bounds (int_bounds_info). + !! @param[in] iy Global Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Global Z-direction loop bounds (int_bounds_info). + pure subroutine s_compute_cylindrical_viscous_source_flux(velL_vf, & + dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, dvelR_dy_vf, dvelR_dz_vf, & + flux_src_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims) :: avg_v_int !!< Averaged interface velocity $(v_x, v_y, v_z)$ (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !!< Averaged interface $\partial v_i/\partial x$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !!< Averaged interface $\partial v_i/\partial y$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !!< Averaged interface $\partial v_i/\partial z$ (grid dir 3). + + real(wp), dimension(num_dims) :: stress_vector_shear !!< Shear stress vector $(\sigma_{N1}, \sigma_{N2}, \sigma_{N3})$ on N-face (grid directions). + real(wp) :: stress_normal_bulk !!< Normal bulk stress component $\sigma_{NN}$ on N-face. + + real(wp) :: Re_s, Re_b !!< Effective interface shear and bulk Reynolds numbers. + real(wp), dimension(num_dims) :: vel_src_int !!< Interface velocity $(v_1,v_2,v_3)$ (grid directions) for viscous work. + real(wp) :: r_eff !!< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !!< Common term $-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s$ for shear stress diagonal. + real(wp) :: divergence_cyl !!< Full divergence $\nabla \cdot \mathbf{v}$ in cylindrical coordinates. + + integer :: j, k, l !!< Loop iterators for $x, y, z$ grid directions. + integer :: i_vel !!< Loop iterator for velocity components. + integer :: idx_rp(3) !!< Indices $(j,k,l)$ of 'right' point for averaging. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, & + !$acc Re_s, Re_b, vel_src_int, r_eff, divergence_cyl, & + !$acc stress_vector_shear, stress_normal_bulk, div_v_term_const) + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface + ! For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + !$acc loop seq + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + & + dvelR_dx_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + & + dvelR_dy_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if + if (num_dims > 2) then + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + & + dvelR_dz_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp + end if + end do + + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + vel_src_int = vel_src_rsx_vf(j, k, l, 1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + Re_s = Re_avg_rsy_vf(k, j, l, 1) + Re_b = Re_avg_rsy_vf(k, j, l, 2) + vel_src_int = vel_src_rsy_vf(k, j, l, 1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + Re_s = Re_avg_rsz_vf(l, k, j, 1) + Re_b = Re_avg_rsz_vf(l, k, j, 2) + vel_src_int = vel_src_rsz_vf(l, k, j, 1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + if (num_dims > 2) then + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + end if + + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp + + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s + + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + if (num_dims > 1) then + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + end if + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + end if + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + end if + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s + div_v_term_const + end if + end select + + !$acc loop seq + do i_vel = 1, num_dims + flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) = flux_src_vf(momxb + i_vel - 1)%sf(j, k, l) - stress_vector_shear(i_vel) + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + end do + end if + + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b + + flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) = flux_src_vf(momxb + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(E_idx)%sf(j, k, l) = flux_src_vf(E_idx)%sf(j, k, l) - vel_src_int(norm_dir)*stress_normal_bulk + end if + + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cylindrical_viscous_source_flux + + !> @brief Computes Cartesian viscous source flux contributions for momentum and energy. + !! Calculates averaged velocity gradients, gets Re and interface velocities, + !! calls helpers for shear/bulk stress, then updates `flux_src_vf`. + !! @param[in] velL_vf Left boundary velocity (num_dims scalar_field). + !! @param[in] dvelL_dx_vf Left boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelL_dy_vf Left boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelL_dz_vf Left boundary d(vel)/dz (num_dims scalar_field). + !! @param[in] velR_vf Right boundary velocity (num_dims scalar_field). + !! @param[in] dvelR_dx_vf Right boundary d(vel)/dx (num_dims scalar_field). + !! @param[in] dvelR_dy_vf Right boundary d(vel)/dy (num_dims scalar_field). + !! @param[in] dvelR_dz_vf Right boundary d(vel)/dz (num_dims scalar_field). + !! @param[inout] flux_src_vf Intercell source flux array to update (sys_size scalar_field). + !! @param[in] norm_dir Interface normal direction (1=x, 2=y, 3=z). + !! @param[in] ix X-direction loop bounds (int_bounds_info). + !! @param[in] iy Y-direction loop bounds (int_bounds_info). + !! @param[in] iz Z-direction loop bounds (int_bounds_info). + pure subroutine s_compute_cartesian_viscous_source_flux(velL_vf, & + dvelL_dx_vf, & + dvelL_dy_vf, & + dvelL_dz_vf, & + velR_vf, & + dvelR_dx_vf, & + dvelR_dy_vf, & + dvelR_dz_vf, & + flux_src_vf, & + norm_dir, & + ix, iy, iz) + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + + real(wp) :: divergence_v !< Velocity divergence at interface. + + !$acc parallel loop collapse(3) gang vector default(present) & + !$acc private(idx_right_phys, vel_grad_avg, & + !$acc current_tau_shear, current_tau_bulk, vel_src_at_interface, & + !$acc Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx) + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + if (num_dims > 1) then + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + if (num_dims > 2) then + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, l_loop) + & + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), idx_right_phys(3))) + end if + end do + + divergence_v = 0.0_wp + do i_dim = 1, num_dims + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) + end do + + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + Re_shear = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 1) + Re_bulk = Re_avg_rsy_vf(k_loop, j_loop, l_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsy_vf(k_loop, j_loop, l_loop, i_dim) + end do + else + Re_shear = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 1) + Re_bulk = Re_avg_rsz_vf(l_loop, k_loop, j_loop, 2) + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsz_vf(l_loop, k_loop, j_loop, i_dim) + end do + end if + + if (shear_stress) then + ! current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_shear(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if + + if (bulk_stress) then + ! current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) + + do i_dim = 1, num_dims + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(momxb + i_dim - 1)%sf(j_loop, k_loop, l_loop) - current_tau_bulk(norm_dir, i_dim) + + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) = & + flux_src_vf(E_idx)%sf(j_loop, k_loop, l_loop) - & + vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do + end if + + end do + end do + end do + !$acc end parallel loop + + end subroutine s_compute_cartesian_viscous_source_flux + + !> @brief Calculates shear stress tensor components. + !! tau_ij_shear = ( (dui/dxj + duj/dxi) - (2/3)*(div_v)*delta_ij ) / Re_shear + !! @param[in] vel_grad_avg Averaged velocity gradient tensor (d(vel_i)/d(coord_j)). + !! @param[in] Re_shear Shear Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_shear_out Calculated shear stress tensor (stress on i-face, j-direction). + pure subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. + + tau_shear_out = 0.0_wp + + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - & + (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do + end do + + end subroutine s_calculate_shear_stress_tensor + + !> @brief Calculates bulk stress tensor components (diagonal only). + !! tau_ii_bulk = (div_v) / Re_bulk. Off-diagonals are zero. + !! @param[in] Re_bulk Bulk Reynolds number. + !! @param[in] divergence_v Velocity divergence (du/dx + dv/dy + dw/dz). + !! @param[out] tau_bulk_out Calculated bulk stress tensor (stress on i-face, i-direction). + pure subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + !$acc routine seq + + implicit none + + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. + + tau_bulk_out = 0.0_wp + + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do + + end subroutine s_calculate_bulk_stress_tensor + + !> Deallocation and/or disassociation procedures that are + !! needed to finalize the selected Riemann problem solver + !! @param flux_vf Intercell fluxes + !! @param flux_src_vf Intercell source fluxes + !! @param flux_gsrc_vf Intercell geometric source fluxes + !! @param norm_dir Dimensional splitting coordinate direction + !! @param ix Index bounds in first coordinate direction + !! @param iy Index bounds in second coordinate direction + !! @param iz Index bounds in third coordinate direction + pure subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, & + flux_gsrc_vf, & + norm_dir) + + type(scalar_field), & + dimension(sys_size), & + intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + + integer, intent(in) :: norm_dir + + integer :: i, j, k, l !< Generic loop iterators + + ! Reshaping Outputted Data in y-direction + if (norm_dir == 2) then + !$acc parallel loop collapse(3) gang vector default(present) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(advxb)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(k, j, l) = & + flux_rsy_vf(j, k, l, i) + if (cyl_coord) then + flux_gsrc_vf(i)%sf(k, j, l) = & + flux_gsrc_rsy_vf(j, k, l, i) + end if + end do + end do + end do + end do + + ! Reshaping Outputted Data in z-direction + elseif (norm_dir == 3) then + !$acc parallel loop collapse(3) gang vector default(present) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(advxb)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(l, k, j) = & + flux_rsz_vf(j, k, l, i) + if (grid_geometry == 3) then + flux_gsrc_vf(i)%sf(l, k, j) = & + flux_gsrc_rsz_vf(j, k, l, i) + end if + end do + end do + end do + end do + + elseif (norm_dir == 1) then + !$acc parallel loop collapse(3) gang vector default(present) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(advxb)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, advxb) + do i = 1, sys_size + flux_vf(i)%sf(j, k, l) = & + flux_rsx_vf(j, k, l, i) + end do + end do + end do + end do + end if + + if (riemann_solver == 1 .or. riemann_solver == 4) then + !$acc parallel loop collapse(4) gang vector default(present) + do i = advxb + 1, advxe + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (norm_dir == 2) then + flux_src_vf(i)%sf(k, j, l) = & + flux_src_rsy_vf(j, k, l, i) + else if (norm_dir == 3) then + flux_src_vf(i)%sf(l, k, j) = & + flux_src_rsz_vf(j, k, l, i) + else if (norm_dir == 1) then + flux_src_vf(i)%sf(j, k, l) = & + flux_src_rsx_vf(j, k, l, i) + end if + end do + end do + end do + end do + end if + + + end subroutine s_finalize_riemann_solver + + !> Module deallocation and/or disassociation procedures + impure subroutine s_finalize_riemann_solvers_module + + if (viscous) then + @:DEALLOCATE(Re_avg_rsx_vf) + end if + @:DEALLOCATE(vel_src_rsx_vf) + @:DEALLOCATE(flux_rsx_vf) + @:DEALLOCATE(flux_src_rsx_vf) + @:DEALLOCATE(flux_gsrc_rsx_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsx_vf) + end if + + if (n == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsy_vf) + end if + @:DEALLOCATE(vel_src_rsy_vf) + @:DEALLOCATE(flux_rsy_vf) + @:DEALLOCATE(flux_src_rsy_vf) + @:DEALLOCATE(flux_gsrc_rsy_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsy_vf) + end if + + if (p == 0) return + + if (viscous) then + @:DEALLOCATE(Re_avg_rsz_vf) + end if + @:DEALLOCATE(vel_src_rsz_vf) + @:DEALLOCATE(flux_rsz_vf) + @:DEALLOCATE(flux_src_rsz_vf) + @:DEALLOCATE(flux_gsrc_rsz_vf) + if (qbmm) then + @:DEALLOCATE(mom_sp_rsz_vf) + end if + + end subroutine s_finalize_riemann_solvers_module + end module m_riemann_solvers \ No newline at end of file From 15ff1ceb31b7052fb7d82d4e3ccd176d57c96734 Mon Sep 17 00:00:00 2001 From: "Al-Mahrouqi, Mohammed Said Hamed Humaid" Date: Mon, 9 Jun 2025 21:25:54 -0400 Subject: [PATCH 58/58] Update m_riemann_solvers.fpp --- src/simulation/m_riemann_solvers.fpp | 1 - 1 file changed, 1 deletion(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 717dd2d98..ae1ea8057 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -2760,7 +2760,6 @@ contains if (surface_tension) then call s_compute_capilary_source_flux( & - q_prim_vf, & vel_src_rsx_vf, & vel_src_rsy_vf, & vel_src_rsz_vf, &