!> !! @file m_riemann_solvers.f90 !! @brief Contains module m_riemann_solvers !! @author S. Bryngelson, K. Schimdmayer, V. Coralic, J. Meng, K. Maeda, T. Colonius !! @version 1.0 !! @date JUNE 06 2019 !> @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 module m_riemann_solvers ! Dependencies ============================================================= 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 ! ========================================================================== implicit none private; public :: s_initialize_riemann_solvers_module, & s_riemann_solver, & s_hll_riemann_solver, & s_hllc_riemann_solver, & s_convert_species_to_mixture_variables_riemann_acc, & s_finalize_riemann_solvers_module abstract interface ! ======================================================= !> Abstract interface 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 !! @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_abstract_riemann_solver(qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, 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) import :: scalar_field, int_bounds_info, sys_size, startx, starty, startz real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat 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 end subroutine s_abstract_riemann_solver !> The abstract interface to the subroutines that are used to calculate !! the Roe and arithmetic average states. For more information refer to: !! 1) s_compute_roe_average_state !! 2) s_compute_arithmetic_average_state !! @param i First coordinate location index !! @param j Second coordinate location index !! @param k Third coordinate location index subroutine s_compute_abstract_average_state(qL_prim_rs_vf, qR_prim_rs_vf,i, j, k) import :: scalar_field, int_bounds_info, sys_size integer, intent(IN) :: i, j, k type(scalar_field), dimension(sys_size), intent(IN) :: qL_prim_rs_vf, qR_prim_rs_vf end subroutine s_compute_abstract_average_state !> The abstract interface to the subroutines that are utilized to compute !! the wave speeds of the Riemann problem either directly or by the means !! of pressure-velocity estimates. For more information please refer to: !! 1) s_compute_direct_wave_speeds !! 2) s_compute_pressure_velocity_wave_speeds !! @param i First coordinate location index !! @param j Second coordinate location index !! @param k Third coordinate location index subroutine s_compute_abstract_wave_speeds(i, j, k) integer, intent(IN) :: i, j, k end subroutine s_compute_abstract_wave_speeds !> The abstract interface 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_abstract_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) import :: scalar_field, int_bounds_info, num_dims, sys_size type(scalar_field), & dimension(num_dims), & 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 end subroutine s_compute_abstract_viscous_source_flux end interface ! ============================================================ type(scalar_field), allocatable, dimension(:) :: qL_prim_rs_vf type(scalar_field), allocatable, dimension(:) :: qR_prim_rs_vf type(scalar_field), allocatable, dimension(:) :: flux_rs_vf, flux_src_rs_vf type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rs_vf !< type(scalar_field), allocatable, dimension(:) :: vel_src_rs_vf !> The left (L) and right (R) WENO-reconstructed cell-boundary values of the !! cell-average primitive variables that define the left and right states of !! the Riemann problem. Variables qK_prim_rs_vf, K = L or R, are obtained by !! reshaping (RS) qK_prim_vf in a coordinate direction that is normal to the !! cell-boundaries along which the fluxes are to be determined. !> @{ type(scalar_field), allocatable, dimension(:) :: qL_prim_rsx_vf type(scalar_field), allocatable, dimension(:) :: qR_prim_rsx_vf type(scalar_field), allocatable, dimension(:) :: qL_prim_rsy_vf type(scalar_field), allocatable, dimension(:) :: qR_prim_rsy_vf type(scalar_field), allocatable, dimension(:) :: qL_prim_rsz_vf type(scalar_field), allocatable, dimension(:) :: qR_prim_rsz_vf !> @} !> @} type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rsx_vf !< type(scalar_field), allocatable, dimension(:) :: flux_gsrc_rsy_vf !< type(scalar_field), allocatable, dimension(:) :: flux_gsrc_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. ! 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. type(scalar_field), allocatable, dimension(:) :: vel_src_rsx_vf type(scalar_field), allocatable, dimension(:):: vel_src_rsy_vf type(scalar_field), allocatable, dimension(:) :: vel_src_rsz_vf !> @} !> 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 and kappaK_rs_vf, where ds = dx, dy or dz. !> @{ real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_rsx_vf_flat, flux_src_rsx_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_rsy_vf_flat, flux_src_rsy_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_rsz_vf_flat, flux_src_rsz_vf_flat !> @} real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf_flat !< real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsy_vf_flat !< real(kind(0d0)), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsz_vf_flat !< !! 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. ! 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(kind(0d0)), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: vel_src_rsy_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: vel_src_rsz_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: mom_sp_rsx_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: mom_sp_rsy_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: mom_sp_rsz_vf_flat !> @name Left and right, WENO-reconstructed, cell-boundary values of cell-average !! partial densities, density, velocity, pressure, internal energy, energy, enthalpy, volume !! fractions, mass fractions, the specific heat ratio and liquid stiffness functions, speed !! of sound, shear and volume Reynolds numbers and the Weber numbers. These !! variables are left and right states of the Riemann problem obtained from !! qK_prim_rs_vf and kappaK_rs_vf. !> @{ !> @} !> @name Left and right, WENO-reconstructed, cell-boundary values of cell-average !! bubble density, radius, radial velocity, pressure, wall pressure, and modified !! pressure. These variables are left and right states of the Riemann problem obtained from !! qK_prim_rs_vf and kappaK_rs_vf. !> @{ real(kind(0d0)) :: nbub_L, nbub_R real(kind(0d0)), allocatable, dimension(:) :: R0_L, R0_R real(kind(0d0)), allocatable, dimension(:) :: V0_L, V0_R real(kind(0d0)), allocatable, dimension(:) :: P0_L, P0_R real(kind(0d0)), allocatable, dimension(:) :: pbw_L, pbw_R real(kind(0d0)), allocatable, dimension(:, :) :: moms_L, moms_R real(kind(0d0)) :: ptilde_L, ptilde_R !> @} !$acc declare create(nbub_L, nbub_R, R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, moms_L, moms_R, ptilde_L, ptilde_R ) !> @name Gamma-related constants for use in exact Riemann solver (following Toro (1999) pp.153) !> @{ real(kind(0d0)) :: G1_L, G1_R real(kind(0d0)) :: G2_L, G2_R real(kind(0d0)) :: G3_L, G3_R real(kind(0d0)) :: G4_L, G4_R real(kind(0d0)) :: G5_L, G5_R real(kind(0d0)) :: G6_L, G6_R real(kind(0d0)) :: G7_L, G7_R real(kind(0d0)) :: G8_L, G8_R !> @} !> @name Star region pressure and velocity !> @{ real(kind(0d0)) :: pres_S real(kind(0d0)) :: vel_S !> @} !> @name Intercell solution used to calculated intercell flux !> @{ real(kind(0d0)), allocatable, dimension(:) :: alpha_rho_IC real(kind(0d0)) :: rho_IC real(kind(0d0)), allocatable, dimension(:) :: vel_IC real(kind(0d0)) :: pres_IC real(kind(0d0)) :: E_IC real(kind(0d0)), allocatable, dimension(:) :: alpha_IC real(kind(0d0)), allocatable, dimension(:) :: tau_e_IC !> @} !> @name Surface tension pressure contribution !> @{ real(kind(0d0)) :: dpres_L, dpres_R !> @} !$acc declare create(pres_S, vel_S, alpha_IC, alpha_rho_IC, vel_IC, pres_IC, E_IC, rho_IC, tau_e_IC, dpres_L, dpres_R) !> @name Roe or arithmetic average density, velocity, enthalpy, volume fractions, !! specific heat ratio function, speed of sound, shear and volume Reynolds !! numbers, Weber numbers and curvatures, at the cell-boundaries, computed !! from the left and the right states of the Riemann problem !> @{ real(kind(0d0)) :: rho_avg real(kind(0d0)), allocatable, dimension(:) :: vel_avg real(kind(0d0)) :: H_avg type(scalar_field), allocatable, dimension(:) :: alpha_avg_rs_vf real(kind(0d0)) :: gamma_avg real(kind(0d0)) :: c_avg type(scalar_field), allocatable, dimension(:) :: Re_avg_rs_vf type(scalar_field), allocatable, dimension(:) :: Re_avg_rsx_vf type(scalar_field), allocatable, dimension(:) :: Re_avg_rsy_vf type(scalar_field), allocatable, dimension(:) :: Re_avg_rsz_vf real(kind(0d0)), allocatable, dimension(:,:,:,:) :: Re_avg_rsx_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: Re_avg_rsy_vf_flat real(kind(0d0)), allocatable, dimension(:,:,:,:) :: Re_avg_rsz_vf_flat !$acc declare create(rho_avg, vel_avg, H_avg, alpha_avg_rs_vf, gamma_avg, c_avg, Re_avg_rs_vf, Re_avg_rsx_vf, Re_avg_rsy_vf, Re_avg_rsz_vf, Re_avg_rsx_vf_flat, Re_avg_rsy_vf_flat, Re_avg_rsz_vf_flat) !> @} !> @name Left, right and star (S) region wave speeds !> @{ real(kind(0d0)) :: s_L, s_R, s_S !> @} !> @name Star region variables (HLLC) !> @{ real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star !> @} !> Minus (M) and plus (P) wave speeds !> @{ real(kind(0d0)) :: s_M, s_P !> @} !> Minus and plus wave speeds functions !> @{ real(kind(0d0)) :: xi_M, xi_P !> @} real(kind(0d0)) :: xi_L, xi_R !$acc declare create(s_L, s_R, s_S, rho_Star, E_Star, p_Star, p_K_Star, s_M, s_P, xi_M, xi_P, xi_L, xi_R) procedure(s_abstract_riemann_solver), & pointer :: s_riemann_solver => null() !< !! Pointer to the procedure that is utilized to calculate either the HLL, !! HLLC or exact intercell fluxes, based on the choice of Riemann solver procedure(s_compute_abstract_average_state), & pointer :: s_compute_average_state => null() !< !! Pointer to the subroutine utilized to calculate either the Roe or the !! arithmetic average state variables, based on the chosen average state procedure(s_compute_abstract_wave_speeds), & pointer :: s_compute_wave_speeds => null() !< !! Pointer to the subroutine that is utilized to compute the wave speeds of !! the Riemann problem either directly or by the means of pressure-velocity !! estimates, based on the selected method of estimation of the wave speeds procedure(s_compute_abstract_viscous_source_flux), & pointer :: s_compute_viscous_source_flux => null() !< !! Pointer to the subroutine that is utilized to compute the viscous source !! flux for either Cartesian or cylindrical geometries. !> @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(qL_prim_rsx_vf, qL_prim_rsy_vf, qL_prim_rsz_vf, qR_prim_rsx_vf, qR_prim_rsy_vf, qR_prim_rsz_vf, & !$acc is1, is2, is3, isx, isy, isz, vel_src_rsx_vf, vel_src_rsy_vf, vel_src_rsz_vf, & !$acc flux_gsrc_rsx_vf, flux_gsrc_rsy_vf, flux_gsrc_rsz_vf) !$acc declare create(& !$acc flux_rsx_vf_flat, flux_src_rsx_vf_flat, flux_rsy_vf_flat, flux_src_rsy_vf_flat, flux_rsz_vf_flat, flux_src_rsz_vf_flat, vel_src_rsx_vf_flat, vel_src_rsy_vf_flat, vel_src_rsz_vf_flat, & !$acc flux_gsrc_rsx_vf_flat, flux_gsrc_rsy_vf_flat, flux_gsrc_rsz_vf_flat, mom_sp_rsx_vf_flat, mom_sp_rsy_vf_flat, mom_sp_rsz_vf_flat) integer :: momxb, momxe integer :: contxb, contxe integer :: advxb, advxe integer :: bubxb, bubxe integer :: intxb, intxe !$acc declare create(momxb, momxe, contxb, contxe, advxb, advxe, bubxb, bubxe, intxb, intxe) real(kind(0d0)),allocatable, dimension(:) :: gammas, pi_infs !$acc declare create(gammas, pi_infs) integer,allocatable, dimension(:) :: rs, vs, ps, ms !$acc declare create(rs, vs, ps, ms) real(kind(0d0)), allocatable, dimension(:, :) :: Res !$acc declare create(Res) contains subroutine s_hll_riemann_solver(qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & ! ------- dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, 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(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat 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(kind(0d0)),dimension(num_fluids) :: alpha_rho_L, alpha_rho_R real(kind(0d0)) :: rho_L, rho_R real(kind(0d0)), dimension(num_dims) :: vel_L, vel_R real(kind(0d0)) :: pres_L, pres_R real(kind(0d0)) :: E_L, E_R real(kind(0d0)) :: H_L, H_R real(kind(0d0)), dimension(num_fluids) :: alpha_L, alpha_R real(kind(0d0)) :: Y_L, Y_R real(kind(0d0)) :: gamma_L, gamma_R real(kind(0d0)) :: pi_inf_L, pi_inf_R real(kind(0d0)) :: c_L, c_R real(kind(0d0)), dimension(2) :: Re_L, Re_R real(kind(0d0)) :: rho_avg real(kind(0d0)),dimension(num_dims) :: vel_avg real(kind(0d0)) :: H_avg real(kind(0d0)) :: gamma_avg real(kind(0d0)) :: c_avg real(kind(0d0)) :: s_L, s_R, s_M, s_P, s_S real(kind(0d0)) :: xi_L, xi_R !< Left and right wave speeds functions real(kind(0d0)) :: xi_M, xi_P real(kind(0d0)) :: nbub_L, nbub_R real(kind(0d0)) :: ptilde_L, ptilde_R real(kind(0d0)) :: vel_L_rms, vel_R_rms, vel_avg_rms real(kind(0d0)) :: blkmod1, blkmod2 real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star real(kind(0d0)) :: Ms_L, Ms_R, pres_SL, pres_SR real(kind(0d0)) :: alpha_L_sum, alpha_R_sum 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_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, 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) if (norm_dir == 1) then !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, vel_avg, Re_L, Re_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_rsx_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsx_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsx_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsx_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids alpha_rho_L(i) = max(0d0, alpha_rho_L(i)) alpha_L(i) = min(max(0d0, alpha_L(i)), 1d0) 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(0d0, alpha_rho_R(i)) alpha_R(i) = min(max(0d0, alpha_R(i)), 1d0) 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) 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) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$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) = 1d0/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) = 0d0 !$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) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) elseif (model_eqns == 3) then c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsx_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R elseif ((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles)) then ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsx_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if s_M = min(0d0, s_L); s_P = max(0d0, s_R) xi_M = (5d-1 + sign(5d-1, s_L)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) xi_P = (5d-1 - sign(5d-1, s_R)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) ! Mass !$acc loop seq do i = 1, contxe flux_rsx_vf_flat(j, k, l, i) = & (s_M*alpha_rho_R(i)*vel_R(dir_idx(1)) & - s_P*alpha_rho_L(i)*vel_L(dir_idx(1)) & + s_M*s_P*(alpha_rho_L(i) & - alpha_rho_R(i))) & /(s_M - s_P) end do ! Momentum if (bubbles) then !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(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) end do else !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(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) end do end if ! Energy if (bubbles) then flux_rsx_vf_flat(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) else flux_rsx_vf_flat(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) end if ! Advection !$acc loop seq do i = advxb, advxe flux_rsx_vf_flat(j, k, l, i) = & (qL_prim_rsx_vf_flat(j, k, l, i) & - qR_prim_rsx_vf_flat(j + 1, k, l, i)) & *s_M*s_P/(s_M - s_P) flux_src_rsx_vf_flat(j, k, l, i) = & (s_M*qR_prim_rsx_vf_flat(j + 1, k, l, i) & - s_P*qL_prim_rsx_vf_flat(j, k, l, i)) & /(s_M - s_P) end do ! Div(U)? !$acc loop seq do i = 1, num_dims vel_src_rsx_vf_flat(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) then ! From HLLC: Kills mass transport @ bubble gas density if (num_fluids > 1) then flux_rsx_vf_flat(j, k, l, contxe) = 0d0 end if end if end do end do end do end if if (norm_dir == 2) then !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, vel_avg, Re_L, Re_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_rsy_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsy_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsy_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsy_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids alpha_rho_L(i) = max(0d0, alpha_rho_L(i)) alpha_L(i) = min(max(0d0, alpha_L(i)), 1d0) 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(0d0, alpha_rho_R(i)) alpha_R(i) = min(max(0d0, alpha_R(i)), 1d0) 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) 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) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$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) = 1d0/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) = 0d0 !$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) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) elseif (model_eqns == 3) then c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsy_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R elseif ((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles)) then ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsy_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if s_M = min(0d0, s_L); s_P = max(0d0, s_R) xi_M = (5d-1 + sign(5d-1, s_L)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) xi_P = (5d-1 - sign(5d-1, s_R)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) ! Mass !$acc loop seq do i = 1, contxe flux_rsy_vf_flat(j, k, l, i) = & (s_M*alpha_rho_R(i)*vel_R(dir_idx(1)) & - s_P*alpha_rho_L(i)*vel_L(dir_idx(1)) & + s_M*s_P*(alpha_rho_L(i) & - alpha_rho_R(i))) & /(s_M - s_P) end do ! Momentum if (bubbles) then !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(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) end do else !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(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) end do end if ! Energy if (bubbles) then flux_rsy_vf_flat(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) else flux_rsy_vf_flat(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) end if ! Advection !$acc loop seq do i = advxb, advxe flux_rsy_vf_flat(j, k, l, i) = & (qL_prim_rsy_vf_flat(j, k, l, i) & - qR_prim_rsy_vf_flat(j + 1, k, l, i)) & *s_M*s_P/(s_M - s_P) flux_src_rsy_vf_flat(j, k, l, i) = & (s_M*qR_prim_rsy_vf_flat(j + 1, k, l, i) & - s_P*qL_prim_rsy_vf_flat(j, k, l, i)) & /(s_M - s_P) end do ! Div(U)? !$acc loop seq do i = 1, num_dims vel_src_rsy_vf_flat(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) then ! From HLLC: Kills mass transport @ bubble gas density if (num_fluids > 1) then flux_rsy_vf_flat(j, k, l, contxe) = 0d0 end if end if end do end do end do end if if (norm_dir == 3) then !$acc parallel loop collapse(3) gang vector default(present) private(alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, vel_avg, Re_L, Re_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_rsz_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsz_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsz_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsz_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids alpha_rho_L(i) = max(0d0, alpha_rho_L(i)) alpha_L(i) = min(max(0d0, alpha_L(i)), 1d0) 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(0d0, alpha_rho_R(i)) alpha_R(i) = min(max(0d0, alpha_R(i)), 1d0) 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) 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) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$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) = 1d0/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) = 0d0 !$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) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) elseif (model_eqns == 3) then c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsz_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R elseif ((model_eqns == 4) .or. (model_eqns == 2 .and. bubbles)) then ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsz_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if s_M = min(0d0, s_L); s_P = max(0d0, s_R) xi_M = (5d-1 + sign(5d-1, s_L)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) xi_P = (5d-1 - sign(5d-1, s_R)) & + (5d-1 - sign(5d-1, s_L)) & * (5d-1 + sign(5d-1, s_R)) ! Mass !$acc loop seq do i = 1, contxe flux_rsz_vf_flat(j, k, l, i) = & (s_M*alpha_rho_R(i)*vel_R(dir_idx(1)) & - s_P*alpha_rho_L(i)*vel_L(dir_idx(1)) & + s_M*s_P*(alpha_rho_L(i) & - alpha_rho_R(i))) & /(s_M - s_P) end do ! Momentum if (bubbles) then !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(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) end do else !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(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) end do end if ! Energy if (bubbles) then flux_rsz_vf_flat(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) else flux_rsz_vf_flat(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) end if ! Advection !$acc loop seq do i = advxb, advxe flux_rsz_vf_flat(j, k, l, i) = & (qL_prim_rsz_vf_flat(j, k, l, i) & - qR_prim_rsz_vf_flat(j + 1, k, l, i)) & *s_M*s_P/(s_M - s_P) flux_src_rsz_vf_flat(j, k, l, i) = & (s_M*qR_prim_rsz_vf_flat(j + 1, k, l, i) & - s_P*qL_prim_rsz_vf_flat(j, k, l, i)) & /(s_M - s_P) end do ! Div(U)? !$acc loop seq do i = 1, num_dims vel_src_rsz_vf_flat(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) then ! From HLLC: Kills mass transport @ bubble gas density if (num_fluids > 1) then flux_rsz_vf_flat(j, k, l, contxe) = 0d0 end if end if end do end do end do end if if(ANY(Re_size > 0) ) 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_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & ! ------ dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, 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(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat 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(kind(0d0)),dimension(num_fluids) :: alpha_rho_L, alpha_rho_R real(kind(0d0)) :: rho_L, rho_R real(kind(0d0)), dimension(num_dims) :: vel_L, vel_R real(kind(0d0)) :: pres_L, pres_R real(kind(0d0)) :: E_L, E_R real(kind(0d0)) :: H_L, H_R real(kind(0d0)), dimension(num_fluids) :: alpha_L, alpha_R real(kind(0d0)) :: Y_L, Y_R real(kind(0d0)) :: gamma_L, gamma_R real(kind(0d0)) :: pi_inf_L, pi_inf_R real(kind(0d0)) :: c_L, c_R real(kind(0d0)), dimension(2) :: Re_L, Re_R real(kind(0d0)) :: rho_avg real(kind(0d0)),dimension(num_dims) :: vel_avg real(kind(0d0)) :: H_avg real(kind(0d0)) :: gamma_avg real(kind(0d0)) :: c_avg real(kind(0d0)) :: s_L, s_R, s_M, s_P, s_S real(kind(0d0)) :: xi_L, xi_R !< Left and right wave speeds functions real(kind(0d0)) :: xi_M, xi_P real(kind(0d0)) :: nbub_L, nbub_R real(kind(0d0)), dimension(nb) :: R0_L, R0_R real(kind(0d0)), dimension(nb) :: V0_L, V0_R real(kind(0d0)), dimension(nb) :: P0_L, P0_R real(kind(0d0)), dimension(nb) :: pbw_L, pbw_R real(kind(0d0)), dimension(nb, nmom) :: moms_L, moms_R real(kind(0d0)) :: ptilde_L, ptilde_R real(kind(0d0)) :: alpha_L_sum, alpha_R_sum, nbub_L_denom, nbub_R_denom real(kind(0d0)) :: PbwR3Lbar, Pbwr3Rbar real(kind(0d0)) :: R3Lbar, R3Rbar real(kind(0d0)) :: R3V2Lbar, R3V2Rbar real(kind(0d0)) :: vel_L_rms, vel_R_rms, vel_avg_rms real(kind(0d0)) :: blkmod1, blkmod2 real(kind(0d0)) :: rho_Star, E_Star, p_Star, p_K_Star real(kind(0d0)) :: pres_SL, pres_SR, Ms_L, Ms_R integer :: i, j, k, l, q !< Generic loop iterators integer :: idx1, idxi ! 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_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, 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) if (norm_dir == 1) then if(model_eqns == 3) then !ME3 !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsx_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsx_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsx_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsx_vf_flat(j, k, l, i)) qL_prim_rsx_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsx_vf_flat(j, k, l, E_idx +& & i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsx_vf_flat(j, k, l, E_idx + i) = qL_prim_rsx_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsx_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsx_vf_flat(j + 1, k, l, i)) qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsx_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsx_vf_flat(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_rsx_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsx_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsx_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsx_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsx_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsx_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsx_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsx_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if if (s_L >= 0d0) then p_Star = pres_L ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsx_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsx_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + contxb - 1)*vel_L(dir_idx(1)) flux_rsx_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*pres_L + pi_infs(i))*vel_L(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsx_vf_flat(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) ! Compute right solution state else if (s_R <= 0d0) then p_Star = pres_R ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsx_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsx_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(1)) flux_rsx_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*pres_R + pi_infs(i))*vel_R(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*pres_R vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsx_vf_flat(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) ! Compute left star solution state else if (s_S >= 0d0) then xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) rho_Star = rho_L*xi_L E_Star = xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) p_Star = rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))) + pres_L !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_L + pi_infs(i)/(1d0 + gammas(i)))* & xi_L**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsx_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsx_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + contxb - 1)*xi_L*s_S flux_rsx_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsx_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_Star*s_S*(s_S*dir_flg(dir_idx(i)) + vel_L(dir_idx(i))* & (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_L - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsx_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S ! Compute right star solution state else xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) rho_Star = rho_R*xi_R E_Star = xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) p_Star = rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))) + pres_R !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_R + pi_infs(i)/(1d0 + gammas(i)))* & xi_R**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsx_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsx_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + contxb - 1)*xi_R*s_S flux_rsx_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsx_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1d0 - dir_flg(dir_idx(i)))) + & dir_flg(dir_idx(i))*p_Star vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_R - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsx_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S end if flux_src_rsx_vf_flat(j, k, l, advxb) = vel_src_rsx_vf_flat(j, k, l, dir_idx(1)) ! Geometrical source flux for cylindrical coordinates if (cyl_coord .and. norm_dir == 2) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsx_vf_flat(j, k, l, i) = flux_rsx_vf_flat(j, k, l, i) end do !$acc loop seq do i = intxb, intxe flux_gsrc_rsx_vf_flat(j, k, l, i) = flux_rsx_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux (substracting the pressure part) flux_gsrc_rsx_vf_flat(j, k, l, momxb - 1 + dir_idx(1)) = & flux_gsrc_rsx_vf_flat(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_rsx_vf_flat(j, k, l, i) = 0d0 end do end if 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, vel_avg) 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_rsx_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsx_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsx_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsx_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 !$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) end do rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 !$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) end do E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*alpha_rho_L(i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*alpha_rho_R(i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Momentum flux. ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) if (bubbles .neqv. .true.) then !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do else ! Include p_tilde !$acc loop seq do i = 1, num_dims flux_rsx_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do end if flux_rsx_vf_flat(j, k, l, E_idx) = 0.d0 !$acc loop seq do i = alf_idx, alf_idx !only advect the void fraction flux_rsx_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = 0d0 !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsx_vf_flat(j, k, l, advxb) = vel_src_rsx_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables if (bubbles) then !$acc loop seq do i = bubxb, bubxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do end if ! Geometrical source flux for cylindrical coordinates end do end do end do elseif(model_eqns == 2 .and. bubbles) 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) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsx_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsx_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_L = rho_L + qL_prim_rsx_vf_flat(j, k, l,i) gamma_L = gamma_L+ qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsx_vf_flat(j , k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_L = rho_L + qL_prim_rsx_vf_flat(j, k, l, i) gamma_L = gamma_L+ qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*pi_infs(i) end do else rho_L = qL_prim_rsx_vf_flat(j , k, l, 1) gamma_L = gammas(1) pi_inf_L = pi_infs(1) end if rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_R = rho_R + qR_prim_rsx_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_R = rho_R + qR_prim_rsx_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else rho_R = qR_prim_rsx_vf_flat(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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_rsx_vf_flat(j, k, l, rs(i) ) R0_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, rs(i)) V0_L(i) = qL_prim_rsx_vf_flat(j, k, l, vs(i)) V0_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, vs(i)) if (.not. polytropic) then P0_L(i) = qL_prim_rsx_vf_flat(j, k, l, ps(i)) P0_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, ps(i)) end if end do !call s_comp_n_from_prim(qL_prim_rsx_vf_flat(j, k, l, E_idx + num_fluids), R0_L, nbub_L) !call s_comp_n_from_prim(qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids), R0_R, nbub_R) nbub_L_denom = 0d0 nbub_R_denom = 0d0 !$acc loop seq do i = 1, nb nbub_L_denom = nbub_L_denom + (R0_L(i)**3d0)*weight(i) nbub_R_denom = nbub_R_denom + (R0_R(i)**3d0)*weight(i) end do nbub_L = (3.d0/(4.d0*pi))*qL_prim_rsx_vf_flat(j, k, l, E_idx + num_fluids)/nbub_L_denom nbub_R = (3.d0/(4.d0*pi))*qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom !$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), 0d0) pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0d0) 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_rsx_vf_flat(j, k, l, 4) PbwR3Rbar = mom_sp_rsx_vf_flat(j + 1, k, l, 4) R3Lbar = mom_sp_rsx_vf_flat(j, k, l, 1) R3Rbar = mom_sp_rsx_vf_flat(j + 1, k, l, 1) R3V2Lbar = mom_sp_rsx_vf_flat(j, k, l, 3) R3V2Rbar = mom_sp_rsx_vf_flat(j + 1, k, l, 3) else PbwR3Lbar = 0d0 PbwR3Rbar = 0d0 R3Lbar = 0d0 R3Rbar = 0d0 R3V2Lbar = 0d0 R3V2Rbar = 0d0 !$acc loop seq do i = 1, nb PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3.d0)*weight(i) PbwR3Rbar = PbwR3Rbar +pbw_R(i)*(R0_R(i)**3.d0)*weight(i) R3Lbar = R3Lbar + (R0_L(i)**3.d0)*weight(i) R3Rbar = R3Rbar + (R0_R(i)**3.d0)*weight(i) R3V2Lbar = R3V2Lbar + (R0_L(i)**3.d0)*(V0_L(i)**2.d0)*weight(i) R3V2Rbar = R3V2Rbar + (R0_R(i)**3.d0)*(V0_R(i)**2.d0)*weight(i) end do end if if (qL_prim_rsx_vf_flat(j , k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf)& & then ptilde_L = qL_prim_rsx_vf_flat(j , k, l, E_idx + num_fluids)*pres_L else ptilde_L = qL_prim_rsx_vf_flat(j , k, l, E_idx + num_fluids)*(pres_L -& & PbwR3Lbar/R3Lbar - & rho_L*R3V2Lbar/R3Lbar) end if if (qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar <& & small_alf) then ptilde_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids)*pres_R else ptilde_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids)*(pres_R -& & PbwR3Rbar/R3Rbar - & rho_R*R3V2Rbar/R3Rbar) end if if ((ptilde_L .ne. ptilde_L) .or. (ptilde_R .ne. ptilde_R)) then end if !ptil(j, k, l) = 0.5d0*(ptilde_L + ptilde_R) rho_avg = 5d-1*(rho_L + rho_R) H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsx_vf_flat(j , k, l, E_idx + 1)/blkmod1 + qL_prim_rsx_vf_flat(j,& & k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 + qR_prim_rsx_vf_flat(j& & + 1, k, l, E_idx + 2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - qL_prim_rsx_vf_flat(j , k, l, E_idx + num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do if (bubbles .and. (num_fluids > 1)) then ! Kill mass transport @ gas density flux_rsx_vf_flat(j, k, l, contxe) = 0.d0 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_rsx_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R )) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsx_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsx_vf_flat(j, k, l, dir_idx(i)) = & xi_M*(vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsx_vf_flat(j, k, l, advxb) = vel_src_rsx_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables !$acc loop seq do i = bubxb, bubxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Geometrical source flux for cylindrical coordinates end do end do end do !$acc end parallel loop else !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end idx1 = 1; if (dir_idx(1).eq.2) idx1 = 2; if (dir_idx(1).eq.3) idx1 = 3 vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsx_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsx_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsx_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsx_vf_flat(j, k, l, i)) qL_prim_rsx_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsx_vf_flat(j, k, l, E_idx& & + i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsx_vf_flat(j, k, l, E_idx + i) = qL_prim_rsx_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsx_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsx_vf_flat(j + 1, k, l, i)) qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsx_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsx_vf_flat(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_rsx_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsx_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsx_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsx_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = (5d-1*(vel_L(1) + vel_R(1)))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(2) + vel_R(2)))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(3) + vel_R(3)))**2d0 end if H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(2) + sqrt(rho_R)*vel_R(2))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(3) + sqrt(rho_R)*vel_R(3))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsx_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsx_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsx_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsx_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsx_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if if(wave_speeds == 1) then s_L = min(vel_L(idx1) - c_L, vel_R(idx1) - c_R) s_R = max(vel_R(idx1) + c_R, vel_L(idx1) + c_L) s_S = (pres_R - pres_L + 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))) elseif(wave_speeds == 2) then pres_SL = 5d-1*(pres_L + pres_R+ rho_avg*c_avg* & (vel_L(idx1) - & vel_R(idx1))) pres_SR = pres_SL Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + gamma_R))))) s_L = vel_L(idx1) - c_L*Ms_L s_R = vel_R(idx1) + c_R*Ms_R s_S = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) 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 idxi = dir_idx(i) flux_rsx_vf_flat(j, k, l, contxe + idxi) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idxi) + & s_M*(xi_L*(dir_flg(idxi)*s_S + & (1d0 - 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 + & (1d0 - dir_flg(idxi))* & vel_R(idxi)) - vel_R(idxi))) + & dir_flg(idxi)*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsx_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsx_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsx_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsx_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims idxi = dir_idx(i) vel_src_rsx_vf_flat(j, k, l, idxi) = & xi_M*(vel_L(idxi) + & dir_flg(idxi)* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(idxi) + & dir_flg(idxi)* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsx_vf_flat(j, k, l, advxb) = vel_src_rsx_vf_flat(j, k, l, idx1) ! Geometrical source flux for cylindrical coordinates end do end do end do end if end if if (norm_dir == 2) then if(model_eqns == 3) then !ME3 !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsy_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsy_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsy_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsy_vf_flat(j, k, l, i)) qL_prim_rsy_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsy_vf_flat(j, k, l, E_idx +& & i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsy_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsy_vf_flat(j, k, l, E_idx + i) = qL_prim_rsy_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsy_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsy_vf_flat(j + 1, k, l, i)) qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsy_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsy_vf_flat(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_rsy_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsy_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsy_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsy_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsy_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsy_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsy_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsy_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if if (s_L >= 0d0) then p_Star = pres_L ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsy_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsy_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + contxb - 1)*vel_L(dir_idx(1)) flux_rsy_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*pres_L + pi_infs(i))*vel_L(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsy_vf_flat(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) ! Compute right solution state else if (s_R <= 0d0) then p_Star = pres_R ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsy_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsy_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(1)) flux_rsy_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*pres_R + pi_infs(i))*vel_R(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*pres_R vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsy_vf_flat(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) ! Compute left star solution state else if (s_S >= 0d0) then xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) rho_Star = rho_L*xi_L E_Star = xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) p_Star = rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))) + pres_L !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_L + pi_infs(i)/(1d0 + gammas(i)))* & xi_L**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsy_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsy_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + contxb - 1)*xi_L*s_S flux_rsy_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsy_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_Star*s_S*(s_S*dir_flg(dir_idx(i)) + vel_L(dir_idx(i))* & (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_L - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsy_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S ! Compute right star solution state else xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) rho_Star = rho_R*xi_R E_Star = xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) p_Star = rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))) + pres_R !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_R + pi_infs(i)/(1d0 + gammas(i)))* & xi_R**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsy_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsy_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + contxb - 1)*xi_R*s_S flux_rsy_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsy_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1d0 - dir_flg(dir_idx(i)))) + & dir_flg(dir_idx(i))*p_Star vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_R - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsy_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S end if flux_src_rsy_vf_flat(j, k, l, advxb) = vel_src_rsy_vf_flat(j, k, l, dir_idx(1)) ! Geometrical source flux for cylindrical coordinates if (cyl_coord .and. norm_dir == 2) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsy_vf_flat(j, k, l, i) = flux_rsy_vf_flat(j, k, l, i) end do !$acc loop seq do i = intxb, intxe flux_gsrc_rsy_vf_flat(j, k, l, i) = flux_rsy_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux (substracting the pressure part) flux_gsrc_rsy_vf_flat(j, k, l, momxb - 1 + dir_idx(1)) = & flux_gsrc_rsy_vf_flat(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_rsy_vf_flat(j, k, l, i) = 0d0 end do end if 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, vel_avg) 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_rsy_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsy_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsy_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsy_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 !$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) end do rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 !$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) end do E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*alpha_rho_L(i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*alpha_rho_R(i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Momentum flux. ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) if (bubbles .neqv. .true.) then !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do else ! Include p_tilde !$acc loop seq do i = 1, num_dims flux_rsy_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do end if flux_rsy_vf_flat(j, k, l, E_idx) = 0.d0 !$acc loop seq do i = alf_idx, alf_idx !only advect the void fraction flux_rsy_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = 0d0 !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsy_vf_flat(j, k, l, advxb) = vel_src_rsy_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables if (bubbles) then !$acc loop seq do i = bubxb, bubxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do end if ! Geometrical source flux for cylindrical coordinates if (cyl_coord) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsy_vf_flat(j, k, l, i) = flux_rsy_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rsy_vf_flat(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 + & (1d0 - 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 + & (1d0 - 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_rsy_vf_flat(j, k, l, i) = 0d0 end do end if end do end do end do elseif(model_eqns == 2 .and. bubbles) 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) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsy_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsy_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_L = rho_L + qL_prim_rsy_vf_flat(j, k, l,i) gamma_L = gamma_L+ qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsy_vf_flat(j , k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_L = rho_L + qL_prim_rsy_vf_flat(j, k, l, i) gamma_L = gamma_L+ qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*pi_infs(i) end do else rho_L = qL_prim_rsy_vf_flat(j , k, l, 1) gamma_L = gammas(1) pi_inf_L = pi_infs(1) end if rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_R = rho_R + qR_prim_rsy_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_R = rho_R + qR_prim_rsy_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else rho_R = qR_prim_rsy_vf_flat(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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_rsy_vf_flat(j, k, l, rs(i) ) R0_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, rs(i)) V0_L(i) = qL_prim_rsy_vf_flat(j, k, l, vs(i)) V0_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, vs(i)) if (.not. polytropic) then P0_L(i) = qL_prim_rsy_vf_flat(j, k, l, ps(i)) P0_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, ps(i)) end if end do !call s_comp_n_from_prim(qL_prim_rsy_vf_flat(j, k, l, E_idx + num_fluids), R0_L, nbub_L) !call s_comp_n_from_prim(qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids), R0_R, nbub_R) nbub_L_denom = 0d0 nbub_R_denom = 0d0 !$acc loop seq do i = 1, nb nbub_L_denom = nbub_L_denom + (R0_L(i)**3d0)*weight(i) nbub_R_denom = nbub_R_denom + (R0_R(i)**3d0)*weight(i) end do nbub_L = (3.d0/(4.d0*pi))*qL_prim_rsy_vf_flat(j, k, l, E_idx + num_fluids)/nbub_L_denom nbub_R = (3.d0/(4.d0*pi))*qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom !$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), 0d0) pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0d0) 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_rsy_vf_flat(j, k, l, 4) PbwR3Rbar = mom_sp_rsy_vf_flat(j + 1, k, l, 4) R3Lbar = mom_sp_rsy_vf_flat(j, k, l, 1) R3Rbar = mom_sp_rsy_vf_flat(j + 1, k, l, 1) R3V2Lbar = mom_sp_rsy_vf_flat(j, k, l, 3) R3V2Rbar = mom_sp_rsy_vf_flat(j + 1, k, l, 3) else PbwR3Lbar = 0d0 PbwR3Rbar = 0d0 R3Lbar = 0d0 R3Rbar = 0d0 R3V2Lbar = 0d0 R3V2Rbar = 0d0 !$acc loop seq do i = 1, nb PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3.d0)*weight(i) PbwR3Rbar = PbwR3Rbar +pbw_R(i)*(R0_R(i)**3.d0)*weight(i) R3Lbar = R3Lbar + (R0_L(i)**3.d0)*weight(i) R3Rbar = R3Rbar + (R0_R(i)**3.d0)*weight(i) R3V2Lbar = R3V2Lbar + (R0_L(i)**3.d0)*(V0_L(i)**2.d0)*weight(i) R3V2Rbar = R3V2Rbar + (R0_R(i)**3.d0)*(V0_R(i)**2.d0)*weight(i) end do end if if (qL_prim_rsy_vf_flat(j , k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf)& & then ptilde_L = qL_prim_rsy_vf_flat(j , k, l, E_idx + num_fluids)*pres_L else ptilde_L = qL_prim_rsy_vf_flat(j , k, l, E_idx + num_fluids)*(pres_L -& & PbwR3Lbar/R3Lbar - & rho_L*R3V2Lbar/R3Lbar) end if if (qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar <& & small_alf) then ptilde_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids)*pres_R else ptilde_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids)*(pres_R -& & PbwR3Rbar/R3Rbar - & rho_R*R3V2Rbar/R3Rbar) end if if ((ptilde_L .ne. ptilde_L) .or. (ptilde_R .ne. ptilde_R)) then end if !ptil(j, k, l) = 0.5d0*(ptilde_L + ptilde_R) rho_avg = 5d-1*(rho_L + rho_R) H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsy_vf_flat(j , k, l, E_idx + 1)/blkmod1 + qL_prim_rsy_vf_flat(j,& & k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 + qR_prim_rsy_vf_flat(j& & + 1, k, l, E_idx + 2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - qL_prim_rsy_vf_flat(j , k, l, E_idx + num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do if (bubbles .and. (num_fluids > 1)) then ! Kill mass transport @ gas density flux_rsy_vf_flat(j, k, l, contxe) = 0.d0 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_rsy_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R )) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsy_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsy_vf_flat(j, k, l, dir_idx(i)) = & xi_M*(vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsy_vf_flat(j, k, l, advxb) = vel_src_rsy_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables !$acc loop seq do i = bubxb, bubxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Geometrical source flux for cylindrical coordinates if (cyl_coord) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsy_vf_flat(j, k, l, i) = flux_rsy_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rsy_vf_flat(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 + & (1d0 - 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 + & (1d0 - 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_rsy_vf_flat(j, k, l, i) = 0d0 end do end if end do end do end do !$acc end parallel loop else !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end idx1 = 1; if (dir_idx(1).eq.2) idx1 = 2; if (dir_idx(1).eq.3) idx1 = 3 vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsy_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsy_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsy_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsy_vf_flat(j, k, l, i)) qL_prim_rsy_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsy_vf_flat(j, k, l, E_idx& & + i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsy_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsy_vf_flat(j, k, l, E_idx + i) = qL_prim_rsy_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsy_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsy_vf_flat(j + 1, k, l, i)) qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsy_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsy_vf_flat(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_rsy_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsy_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsy_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsy_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = (5d-1*(vel_L(1) + vel_R(1)))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(2) + vel_R(2)))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(3) + vel_R(3)))**2d0 end if H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(2) + sqrt(rho_R)*vel_R(2))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(3) + sqrt(rho_R)*vel_R(3))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsy_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsy_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsy_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsy_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsy_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if if(wave_speeds == 1) then s_L = min(vel_L(idx1) - c_L, vel_R(idx1) - c_R) s_R = max(vel_R(idx1) + c_R, vel_L(idx1) + c_L) s_S = (pres_R - pres_L + 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))) elseif(wave_speeds == 2) then pres_SL = 5d-1*(pres_L + pres_R+ rho_avg*c_avg* & (vel_L(idx1) - & vel_R(idx1))) pres_SR = pres_SL Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + gamma_R))))) s_L = vel_L(idx1) - c_L*Ms_L s_R = vel_R(idx1) + c_R*Ms_R s_S = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) 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 idxi = dir_idx(i) flux_rsy_vf_flat(j, k, l, contxe + idxi) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idxi) + & s_M*(xi_L*(dir_flg(idxi)*s_S + & (1d0 - 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 + & (1d0 - dir_flg(idxi))* & vel_R(idxi)) - vel_R(idxi))) + & dir_flg(idxi)*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsy_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsy_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsy_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsy_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims idxi = dir_idx(i) vel_src_rsy_vf_flat(j, k, l, idxi) = & xi_M*(vel_L(idxi) + & dir_flg(idxi)* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(idxi) + & dir_flg(idxi)* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsy_vf_flat(j, k, l, advxb) = vel_src_rsy_vf_flat(j, k, l, idx1) ! Geometrical source flux for cylindrical coordinates if (cyl_coord) then !Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsy_vf_flat(j, k, l, i) = flux_rsy_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux flux_gsrc_rsy_vf_flat(j, k, l, contxe + idx1) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & (1d0 - 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 + & (1d0 - 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_rsy_vf_flat(j, k, l, i) = 0d0 end do end if end do end do end do end if end if if (norm_dir == 3) then if(model_eqns == 3) then !ME3 !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsz_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsz_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsz_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsz_vf_flat(j, k, l, i)) qL_prim_rsz_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsz_vf_flat(j, k, l, E_idx +& & i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsz_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsz_vf_flat(j, k, l, E_idx + i) = qL_prim_rsz_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsz_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsz_vf_flat(j + 1, k, l, i)) qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsz_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsz_vf_flat(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_rsz_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsz_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsz_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsz_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsz_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsz_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = 0d0 c_R = 0d0 !$acc loop seq do i = 1, num_fluids c_L = c_L + qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qL_prim_rsz_vf_flat(j, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) c_R = c_R + qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)*(1d0/gammas(i) + 1d0)* & (qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) + pi_infs(i)/(gammas(i) + 1d0)) end do c_L = c_L/rho_L c_R = c_R/rho_R end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsz_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + & (pres_L - pres_R)/ & (rho_avg*c_avg)) end if if (s_L >= 0d0) then p_Star = pres_L ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsz_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsz_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + contxb - 1)*vel_L(dir_idx(1)) flux_rsz_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*pres_L + pi_infs(i))*vel_L(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsz_vf_flat(j, k, l, E_idx) = (E_L + pres_L)*vel_L(dir_idx(1)) ! Compute right solution state else if (s_R <= 0d0) then p_Star = pres_R ! Only usefull to recalculate the radial momentum geometric source flux !$acc loop seq do i = 1, num_fluids flux_rsz_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsz_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + contxb - 1)*vel_R(dir_idx(1)) flux_rsz_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*pres_R + pi_infs(i))*vel_R(dir_idx(1)) end do !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*pres_R vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsz_vf_flat(j, k, l, E_idx) = (E_R + pres_R)*vel_R(dir_idx(1)) ! Compute left star solution state else if (s_S >= 0d0) then xi_L = (s_L - vel_L(dir_idx(1)))/(s_L - s_S) rho_Star = rho_L*xi_L E_Star = xi_L*(E_L + (s_S - vel_L(dir_idx(1)))* & (rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1))))) p_Star = rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))) + pres_L !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_L + pi_infs(i)/(1d0 + gammas(i)))* & xi_L**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsz_vf_flat(j, k, l, i + advxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)*s_S flux_rsz_vf_flat(j, k, l, i + contxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + contxb - 1)*xi_L*s_S flux_rsz_vf_flat(j, k, l, i + intxb - 1) = & qL_prim_rsz_vf_flat(j, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = & rho_Star*s_S*(s_S*dir_flg(dir_idx(i)) + vel_L(dir_idx(i))* & (1d0 - dir_flg(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_L - vel_L(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsz_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S ! Compute right star solution state else xi_R = (s_R - vel_R(dir_idx(1)))/(s_R - s_S) rho_Star = rho_R*xi_R E_Star = xi_R*(E_R + (s_S - vel_R(dir_idx(1)))* & (rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) p_Star = rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))) + pres_R !$acc loop seq do i = 1, num_fluids p_K_Star = (pres_R + pi_infs(i)/(1d0 + gammas(i)))* & xi_R**(1d0/gammas(i) + 1d0) - pi_infs(i)/(1d0 + gammas(i)) flux_rsz_vf_flat(j, k, l, i + advxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)*s_S flux_rsz_vf_flat(j, k, l, i + contxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + contxb - 1)*xi_R*s_S flux_rsz_vf_flat(j, k, l, i + intxb - 1) = & qR_prim_rsz_vf_flat(j + 1, k, l, i + advxb - 1)* & (gammas(i)*p_K_Star + pi_infs(i))*s_S end do !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(j, k, l, momxb - 1 + dir_idx(i)) = rho_Star*s_S* & (s_S*dir_flg(dir_idx(i)) + vel_R(dir_idx(i))*(1d0 - dir_flg(dir_idx(i)))) + & dir_flg(dir_idx(i))*p_Star vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))*(s_S*xi_R - vel_R(dir_idx(i))) ! Compute the star velocities for the non-conservative terms end do flux_rsz_vf_flat(j, k, l, E_idx) = (E_Star + p_Star)*s_S end if flux_src_rsz_vf_flat(j, k, l, advxb) = vel_src_rsz_vf_flat(j, k, l, dir_idx(1)) ! Geometrical source flux for cylindrical coordinates if (cyl_coord .and. norm_dir == 2) then ! Substituting the advective flux into the inviscid geometrical source flux !$acc loop seq do i = 1, E_idx flux_gsrc_rsz_vf_flat(j, k, l, i) = flux_rsz_vf_flat(j, k, l, i) end do !$acc loop seq do i = intxb, intxe flux_gsrc_rsz_vf_flat(j, k, l, i) = flux_rsz_vf_flat(j, k, l, i) end do ! Recalculating the radial momentum geometric source flux (substracting the pressure part) flux_gsrc_rsz_vf_flat(j, k, l, momxb - 1 + dir_idx(1)) = & flux_gsrc_rsz_vf_flat(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_rsz_vf_flat(j, k, l, i) = 0d0 end do end if 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, vel_avg) 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_rsz_vf_flat(j, k, l, i) alpha_rho_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, i) end do !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsz_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, contxe + i) end do vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do !$acc loop seq do i = 1, num_fluids alpha_L(i) = qL_prim_rsz_vf_flat(j, k, l, E_idx + i) alpha_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) end do pres_L = qL_prim_rsz_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 !$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) end do rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 !$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) end do E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = 5d-1*(vel_L(i) + vel_R(i)) end do H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) !$acc loop seq do i = 1, num_dims vel_avg(i) = (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))/ & (sqrt(rho_L) + sqrt(rho_R)) end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + vel_avg(i)**2d0 end do if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(alpha_L(1)/blkmod1 + alpha_L(2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(alpha_R(1)/blkmod1 + alpha_R(2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - alpha_L(num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - alpha_R(num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*alpha_rho_L(i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*alpha_rho_R(i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Momentum flux. ! f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) if (bubbles .neqv. .true.) then !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do else ! Include p_tilde !$acc loop seq do i = 1, num_dims flux_rsz_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do end if flux_rsz_vf_flat(j, k, l, E_idx) = 0.d0 !$acc loop seq do i = alf_idx, alf_idx !only advect the void fraction flux_rsz_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = 0d0 !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsz_vf_flat(j, k, l, advxb) = vel_src_rsz_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables if (bubbles) then !$acc loop seq do i = bubxb, bubxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do end if ! Geometrical source flux for cylindrical coordinates if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size flux_gsrc_rsz_vf_flat(j, k, l, i) = 0d0 end do flux_gsrc_rsz_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rsz_vf_flat(j, k, l, momxe) = flux_rsz_vf_flat(j, k, l, momxb + 1) end if end do end do end do elseif(model_eqns == 2 .and. bubbles) 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) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsz_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsz_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_L = rho_L + qL_prim_rsz_vf_flat(j, k, l,i) gamma_L = gamma_L+ qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsz_vf_flat(j , k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_L = rho_L + qL_prim_rsz_vf_flat(j, k, l, i) gamma_L = gamma_L+ qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*pi_infs(i) end do else rho_L = qL_prim_rsz_vf_flat(j , k, l, 1) gamma_L = gammas(1) pi_inf_L = pi_infs(1) end if rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 if(mpp_lim .and. (num_fluids > 2)) then !$acc loop seq do i = 1, num_fluids rho_R = rho_R + qR_prim_rsz_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else if(num_fluids > 2) then !$acc loop seq do i = 1, num_fluids - 1 rho_R = rho_R + qR_prim_rsz_vf_flat(j + 1, k, l, i) gamma_R = gamma_R+ qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do else rho_R = qR_prim_rsz_vf_flat(j + 1, k, l, 1) gamma_R = gammas(1) pi_inf_R = pi_infs(1) end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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_rsz_vf_flat(j, k, l, rs(i) ) R0_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, rs(i)) V0_L(i) = qL_prim_rsz_vf_flat(j, k, l, vs(i)) V0_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, vs(i)) if (.not. polytropic) then P0_L(i) = qL_prim_rsz_vf_flat(j, k, l, ps(i)) P0_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, ps(i)) end if end do !call s_comp_n_from_prim(qL_prim_rsz_vf_flat(j, k, l, E_idx + num_fluids), R0_L, nbub_L) !call s_comp_n_from_prim(qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids), R0_R, nbub_R) nbub_L_denom = 0d0 nbub_R_denom = 0d0 !$acc loop seq do i = 1, nb nbub_L_denom = nbub_L_denom + (R0_L(i)**3d0)*weight(i) nbub_R_denom = nbub_R_denom + (R0_R(i)**3d0)*weight(i) end do nbub_L = (3.d0/(4.d0*pi))*qL_prim_rsz_vf_flat(j, k, l, E_idx + num_fluids)/nbub_L_denom nbub_R = (3.d0/(4.d0*pi))*qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids)/nbub_R_denom !$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), 0d0) pbw_R(i) = f_cpbw_KM(R0(i), R0_R(i), V0_R(i), 0d0) 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_rsz_vf_flat(j, k, l, 4) PbwR3Rbar = mom_sp_rsz_vf_flat(j + 1, k, l, 4) R3Lbar = mom_sp_rsz_vf_flat(j, k, l, 1) R3Rbar = mom_sp_rsz_vf_flat(j + 1, k, l, 1) R3V2Lbar = mom_sp_rsz_vf_flat(j, k, l, 3) R3V2Rbar = mom_sp_rsz_vf_flat(j + 1, k, l, 3) else PbwR3Lbar = 0d0 PbwR3Rbar = 0d0 R3Lbar = 0d0 R3Rbar = 0d0 R3V2Lbar = 0d0 R3V2Rbar = 0d0 !$acc loop seq do i = 1, nb PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3.d0)*weight(i) PbwR3Rbar = PbwR3Rbar +pbw_R(i)*(R0_R(i)**3.d0)*weight(i) R3Lbar = R3Lbar + (R0_L(i)**3.d0)*weight(i) R3Rbar = R3Rbar + (R0_R(i)**3.d0)*weight(i) R3V2Lbar = R3V2Lbar + (R0_L(i)**3.d0)*(V0_L(i)**2.d0)*weight(i) R3V2Rbar = R3V2Rbar + (R0_R(i)**3.d0)*(V0_R(i)**2.d0)*weight(i) end do end if if (qL_prim_rsz_vf_flat(j , k, l, E_idx + num_fluids) < small_alf .or. R3Lbar < small_alf)& & then ptilde_L = qL_prim_rsz_vf_flat(j , k, l, E_idx + num_fluids)*pres_L else ptilde_L = qL_prim_rsz_vf_flat(j , k, l, E_idx + num_fluids)*(pres_L -& & PbwR3Lbar/R3Lbar - & rho_L*R3V2Lbar/R3Lbar) end if if (qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids) < small_alf .or. R3Rbar <& & small_alf) then ptilde_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids)*pres_R else ptilde_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids)*(pres_R -& & PbwR3Rbar/R3Rbar - & rho_R*R3V2Rbar/R3Rbar) end if if ((ptilde_L .ne. ptilde_L) .or. (ptilde_R .ne. ptilde_R)) then end if !ptil(j, k, l) = 0.5d0*(ptilde_L + ptilde_R) rho_avg = 5d-1*(rho_L + rho_R) H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(i) + vel_R(i)))**2d0 end do elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(i) + sqrt(rho_R)*vel_R(i))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end do H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsz_vf_flat(j , k, l, E_idx + 1)/blkmod1 + qL_prim_rsz_vf_flat(j,& & k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 + qR_prim_rsz_vf_flat(j& & + 1, k, l, E_idx + 2)/blkmod2)) else ! Sound speed for bubble mmixture to order O(\alpha) if (mpp_lim .and. (num_fluids > 1)) then c_L = (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/rho_L c_R = (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/rho_R else c_L = & (1d0/gamma_L + 1d0)* & (pres_L + pi_inf_L)/ & (rho_L*(1d0 - qL_prim_rsz_vf_flat(j , k, l, E_idx + num_fluids))) c_R = & (1d0/gamma_R + 1d0)* & (pres_R + pi_inf_R)/ & (rho_R*(1d0 - qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + num_fluids))) end if end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) 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 = 5d-1*(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(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + 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 = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do if (bubbles .and. (num_fluids > 1)) then ! Kill mass transport @ gas density flux_rsz_vf_flat(j, k, l, contxe) = 0.d0 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_rsz_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(i)))* & vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + & dir_flg(dir_idx(i))*(pres_R - ptilde_R )) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsz_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims vel_src_rsz_vf_flat(j, k, l, dir_idx(i)) = & xi_M*(vel_L(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(dir_idx(i)) + & dir_flg(dir_idx(i))* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsz_vf_flat(j, k, l, advxb) = vel_src_rsz_vf_flat(j, k, l, dir_idx(1)) ! Add advection flux for bubble variables !$acc loop seq do i = bubxb, bubxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*nbub_L*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(dir_idx(1)) + s_M*(xi_L - 1d0)) & + xi_P*nbub_R*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(dir_idx(1)) + s_P*(xi_R - 1d0)) end do ! Geometrical source flux for cylindrical coordinates if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size flux_gsrc_rsz_vf_flat(j, k, l, i) = 0d0 end do flux_gsrc_rsz_vf_flat(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 + & (1d0 - 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 + & (1d0 - dir_flg(dir_idx(1)))* & vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) flux_gsrc_rsz_vf_flat(j, k, l, momxe) = flux_rsz_vf_flat(j, k, l, momxb + 1) end if end do end do end do !$acc end parallel loop else !$acc parallel loop collapse(3) gang vector default(present) private(vel_L, vel_R, Re_L, Re_R) do l = is3%beg, is3%end do k = is2%beg, is2%end do j = is1%beg, is1%end idx1 = 1; if (dir_idx(1).eq.2) idx1 = 2; if (dir_idx(1).eq.3) idx1 = 3 vel_L_rms = 0d0; vel_R_rms = 0d0 !$acc loop seq do i = 1, num_dims vel_L(i) = qL_prim_rsz_vf_flat(j, k, l, contxe + i) vel_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, contxe + i) vel_L_rms = vel_L_rms + vel_L(i)**2d0 vel_R_rms = vel_R_rms + vel_R(i)**2d0 end do pres_L = qL_prim_rsz_vf_flat(j, k, l, E_idx) pres_R = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx) rho_L = 0d0 gamma_L = 0d0 pi_inf_L = 0d0 rho_R = 0d0 gamma_R = 0d0 pi_inf_R = 0d0 alpha_L_sum = 0d0 alpha_R_sum = 0d0 if (mpp_lim) then !$acc loop seq do i = 1, num_fluids qL_prim_rsz_vf_flat(j, k, l, i) = max(0d0, qL_prim_rsz_vf_flat(j, k, l, i)) qL_prim_rsz_vf_flat(j, k, l, E_idx + i) = min(max(0d0, qL_prim_rsz_vf_flat(j, k, l, E_idx& & + i)), 1d0) alpha_L_sum = alpha_L_sum + qL_prim_rsz_vf_flat(j, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qL_prim_rsz_vf_flat(j, k, l, E_idx + i) = qL_prim_rsz_vf_flat(j, k, l, E_idx +& & i)/max(alpha_L_sum,sgm_eps) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsz_vf_flat(j + 1, k, l, i) = max(0d0, qR_prim_rsz_vf_flat(j + 1, k, l, i)) qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) = min(max(0d0,qR_prim_rsz_vf_flat(j + 1, k, l,& & E_idx + i)), 1d0) alpha_R_sum = alpha_R_sum + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) end do !$acc loop seq do i = 1, num_fluids qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i) = qR_prim_rsz_vf_flat(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_rsz_vf_flat(j, k, l, i) gamma_L = gamma_L + qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*gammas(i) pi_inf_L = pi_inf_L + qL_prim_rsz_vf_flat(j, k, l, E_idx + i)*pi_infs(i) rho_R = rho_R + qR_prim_rsz_vf_flat(j + 1, k, l, i) gamma_R = gamma_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*gammas(i) pi_inf_R = pi_inf_R + qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + i)*pi_infs(i) end do if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_L(i) = dflt_real if (Re_size(i) > 0) Re_L(i) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_L(i) = qL_prim_rsz_vf_flat(j, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_L(i) end do Re_L(i) = 1d0/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) = 0d0 !$acc loop seq do q = 1, Re_size(i) Re_R(i) = qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + Re_idx(i, q))/Res(i,q) & + Re_R(i) end do Re_R(i) = 1d0/max(Re_R(i), sgm_eps) end do end if E_L = gamma_L*pres_L + pi_inf_L + 5d-1*rho_L*vel_L_rms E_R = gamma_R*pres_R + pi_inf_R + 5d-1*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 rho_avg = 5d-1*(rho_L + rho_R) vel_avg_rms = (5d-1*(vel_L(1) + vel_R(1)))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(2) + vel_R(2)))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (5d-1*(vel_L(3) + vel_R(3)))**2d0 end if H_avg = 5d-1*(H_L + H_R) gamma_avg = 5d-1*(gamma_L + gamma_R) elseif(avg_state == 1) then rho_avg = sqrt(rho_L*rho_R) vel_avg_rms = (sqrt(rho_L)*vel_L(1) + sqrt(rho_R)*vel_R(1))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 if (num_dims.ge.2) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(2) + sqrt(rho_R)*vel_R(2))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if if (num_dims.eq.3) then vel_avg_rms = vel_avg_rms + (sqrt(rho_L)*vel_L(3) + sqrt(rho_R)*vel_R(3))**2d0/ & (sqrt(rho_L) + sqrt(rho_R))**2d0 end if H_avg = (sqrt(rho_L)*H_L + sqrt(rho_R)*H_R)/ & (sqrt(rho_L) + sqrt(rho_R)) gamma_avg = (sqrt(rho_L)*gamma_L + sqrt(rho_R)*gamma_R)/ & (sqrt(rho_L) + sqrt(rho_R)) end if if (mixture_err) then if ((H_avg - 5d-1*vel_avg_rms) < 0d0) then c_avg = sgm_eps else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if else c_avg = sqrt((H_avg - 5d-1*vel_avg_rms)/gamma_avg) end if if (alt_soundspeed) then blkmod1 = ((gammas(1) + 1d0)*pres_L + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_L + & pi_infs(2))/gammas(2) c_L = 1d0/(rho_L*(qL_prim_rsz_vf_flat(j, k, l, E_idx + 1)/blkmod1 & + qL_prim_rsz_vf_flat(j, k, l, E_idx + 2)/blkmod2)) blkmod1 = ((gammas(1) + 1d0)*pres_R + & pi_infs(1))/gammas(1) blkmod2 = ((gammas(2) + 1d0)*pres_R + & pi_infs(2))/gammas(2) c_R = 1d0/(rho_R*(qR_prim_rsz_vf_flat(j + 1, k, l, E_idx + 1)/blkmod1 & + qR_prim_rsz_vf_flat(j + 1, k, l, e_idx + 2)/blkmod2)) else c_L = ((H_L - 5d-1*vel_L_rms)/gamma_L) c_R = ((H_R - 5d-1*vel_R_rms)/gamma_R) end if if (mixture_err .and. c_L < 0d0) then c_L = 100.d0*sgm_eps else c_L = sqrt(c_L) end if if (mixture_err .and. c_R < 0d0) then c_R = 100.d0*sgm_eps else c_R = sqrt(c_R) end if if(any(Re_size > 0)) then !$acc loop seq do i = 1, 2 Re_avg_rsz_vf_flat(j, k, l, i) = 2d0/(1d0/Re_L(i) + 1d0/Re_R(i)) end do end if if(wave_speeds == 1) then s_L = min(vel_L(idx1) - c_L, vel_R(idx1) - c_R) s_R = max(vel_R(idx1) + c_R, vel_L(idx1) + c_L) s_S = (pres_R - pres_L + 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))) elseif(wave_speeds == 2) then pres_SL = 5d-1*(pres_L + pres_R+ rho_avg*c_avg* & (vel_L(idx1) - & vel_R(idx1))) pres_SR = pres_SL Ms_L = max(1d0, sqrt(1d0 + ((5d-1 + gamma_L)/(1d0 + gamma_L))* & (pres_SL/pres_L - 1d0)*pres_L/ & ((pres_L + pi_inf_L/(1d0 + gamma_L))))) Ms_R = max(1d0, sqrt(1d0 + ((5d-1 + gamma_R)/(1d0 + gamma_R))* & (pres_SR/pres_R - 1d0)*pres_R/ & ((pres_R + pi_inf_R/(1d0 + gamma_R))))) s_L = vel_L(idx1) - c_L*Ms_L s_R = vel_R(idx1) + c_R*Ms_R s_S = 5d-1*((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(0d0, s_L); s_P = max(0d0, s_R) ! 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 = (5d-1 + sign(5d-1, s_S)) xi_P = (5d-1 - sign(5d-1, s_S)) !$acc loop seq do i = 1, contxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) 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 idxi = dir_idx(i) flux_rsz_vf_flat(j, k, l, contxe + idxi) = & xi_M*(rho_L*(vel_L(idx1)* & vel_L(idxi) + & s_M*(xi_L*(dir_flg(idxi)*s_S + & (1d0 - 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 + & (1d0 - dir_flg(idxi))* & vel_R(idxi)) - vel_R(idxi))) + & dir_flg(idxi)*(pres_R)) ! if (j==0) print*, 'flux_rs_vf', flux_rs_vf(cont_idx%end+dir_idx(i))%sf(j,k,l) end do ! Energy flux. ! f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) flux_rsz_vf_flat(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)) ! Volume fraction flux !$acc loop seq do i = advxb, advxe flux_rsz_vf_flat(j, k, l, i) = & xi_M*qL_prim_rsz_vf_flat(j, k, l, i) & *(vel_L(idx1) + s_M*(xi_L - 1d0)) & + xi_P*qR_prim_rsz_vf_flat(j + 1, k, l, i) & *(vel_R(idx1) + s_P*(xi_R - 1d0)) end do ! Source for volume fraction advection equation !$acc loop seq do i = 1, num_dims idxi = dir_idx(i) vel_src_rsz_vf_flat(j, k, l, idxi) = & xi_M*(vel_L(idxi) + & dir_flg(idxi)* & s_M*(xi_L - 1d0)) & + xi_P*(vel_R(idxi) + & dir_flg(idxi)* & s_P*(xi_R - 1d0)) !IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0d0 end do flux_src_rsz_vf_flat(j, k, l, advxb) = vel_src_rsz_vf_flat(j, k, l, idx1) ! Geometrical source flux for cylindrical coordinates if (grid_geometry == 3) then !$acc loop seq do i = 1, sys_size flux_gsrc_rsz_vf_flat(j, k, l, i) = 0d0 end do flux_gsrc_rsz_vf_flat(j, k, l, momxb + 1) = & -xi_M*(rho_L*(vel_L(idx1)* & vel_L(idx1) + & s_M*(xi_L*(dir_flg(idx1)*s_S + & (1d0 - 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 + & (1d0 - dir_flg(idx1))* & vel_R(idx1)) - vel_R(idx1)))) flux_gsrc_rsz_vf_flat(j, k, l, momxe) = flux_rsz_vf_flat(j, k, l, momxb + 1) end if end do end do end do end if end if ! Computing HLLC flux and source flux for Euler system of equations ! print*, 'xbounds are: ', is1%beg, is1%end ! print*, 'ybounds are: ', is2%beg, is2%end ! print*, 'zbounds are: ', is3%beg, is3%end ! print*, 'about to get average state' IF(ANY(Re_size > 0) ) 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_hllc_riemann_solver subroutine s_convert_species_to_mixture_variables_riemann_acc( rho_K, & gamma_K, pi_inf_K, & alpha_K, alpha_rho_K, Re_K, k, l, r) !$acc routine seq real(kind(0d0)), intent(INOUT) :: rho_K, gamma_K, pi_inf_K real(kind(0d0)), dimension(:), intent(INOUT) :: alpha_rho_K, alpha_K !< real(kind(0d0)), dimension(:), intent(OUT) :: Re_K !! Partial densities and volume fractions integer, intent(IN) :: k, l, r integer :: i, j !< Generic loop iterators real(kind(0d0)) :: alpha_K_sum ! 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 = 0d0 gamma_K = 0d0 pi_inf_K = 0d0 alpha_K_sum = 0d0 if (mpp_lim) then do i = 1, num_fluids alpha_rho_K(i) = max(0d0, alpha_rho_K(i)) alpha_K(i) = min(max(0d0, alpha_K(i)), 1d0) 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) end do if(any(Re_size > 0)) then do i = 1, 2 Re_K(i) = dflt_real if (Re_size(i) > 0) Re_K(i) = 0d0 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) = 1d0/max(Re_K(i), sgm_eps) end do end if end subroutine s_convert_species_to_mixture_variables_riemann_acc ! ---------------- !! @param l Third coordinate index !> 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(gammas(1:num_fluids)) allocate(pi_infs(1:num_fluids)) do i = 1, num_fluids gammas(i) = fluid_pp(i)%gamma pi_infs(i) = fluid_pp(i)%pi_inf end do !$acc update device(gammas, pi_infs) momxb = mom_idx%beg; momxe = mom_idx%end contxb = cont_idx%beg; contxe = cont_idx%end bubxb = bub_idx%beg; bubxe = bub_idx%end advxb = adv_idx%beg; advxe = adv_idx%end intxb = internalEnergies_idx%beg; intxe = internalEnergies_idx%end !$acc update device(momxb, momxe, contxb, contxe, bubxb, bubxe, advxb, advxe, intxb, intxe) if(bubbles) then allocate(rs(1:nb)) allocate(vs(1:nb)) if(.not. polytropic) then allocate(ps(1:nb)) allocate(ms(1:nb)) end if do i = 1, nb rs(i) = bub_idx%rs(i) vs(i) = bub_idx%vs(i) if(.not. polytropic) then ps(i) = bub_idx%ps(i) ms(i) = bub_idx%ms(i) end if end do !$acc update device(rs, vs) if(.not. polytropic) then !$acc update device(ps, ms) end if end if if(any(Re_size > 0)) then allocate(Res(1:2,1:maxval(Re_size))) end if if(any(Re_size > 0)) 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 allocate (qL_prim_rsx_vf(1:sys_size), qR_prim_rsx_vf(1:sys_size)) allocate (qL_prim_rsy_vf(1:sys_size), qR_prim_rsy_vf(1:sys_size)) allocate (qL_prim_rsz_vf(1:sys_size), qR_prim_rsz_vf(1:sys_size)) allocate (flux_gsrc_rsx_vf(1:sys_size)) allocate (flux_gsrc_rsy_vf(1:sys_size)) allocate (flux_gsrc_rsz_vf(1:sys_size)) allocate (vel_src_rsx_vf(1:num_dims)) allocate (vel_src_rsy_vf(1:num_dims)) allocate (vel_src_rsz_vf(1:num_dims)) if (any(Re_size > 0)) then ! TODO: check this is the proper allocation for ! Re_avg_rs_vf allocate (Re_avg_rs_vf(1:2)) allocate (Re_avg_rsx_vf(1:2)) allocate (Re_avg_rsy_vf(1:2)) allocate (Re_avg_rsz_vf(1:2)) end if allocate (vel_avg(1:num_dims)) if (riemann_solver == 3) then allocate (alpha_rho_IC(1:cont_idx%end), vel_IC(1:num_dims)) allocate (alpha_IC(1:num_fluids)) end if ! Associating procedural pointer to the subroutine that will be ! utilized to calculate the solution of a given Riemann problem if (riemann_solver == 1) then s_riemann_solver => s_hll_riemann_solver elseif (riemann_solver == 2) then s_riemann_solver => s_hllc_riemann_solver end if if (bubbles) then allocate (R0_L(nb), R0_R(nb)) allocate (V0_L(nb), V0_R(nb)) allocate (pbw_L(nb), pbw_R(nb)) if (qbmm) then allocate (moms_L(nb, nmom), moms_R(nb, nmom)) else if (.not. polytropic) then allocate (P0_L(nb), P0_R(nb)) end if end if end if ! Associating the procedural pointers to the procedures that will be ! utilized to compute the average state and estimate the wave speeds ! Associating procedural pointer to the subroutine that will be ! utilized to compute the viscous source flux if (grid_geometry == 3) then s_compute_viscous_source_flux => s_compute_cylindrical_viscous_source_flux else s_compute_viscous_source_flux => s_compute_cartesian_viscous_source_flux end if ! Associating the procedural pointer to the appropriate subroutine ! that will be utilized in the conversion to the mixture variables if (model_eqns == 1) then ! Gamma/pi_inf model s_convert_to_mixture_variables => & s_convert_mixture_to_mixture_variables elseif (bubbles) then ! Volume fraction for bubbles s_convert_to_mixture_variables => & s_convert_species_to_mixture_variables_bubbles else ! Volume fraction model s_convert_to_mixture_variables => & s_convert_species_to_mixture_variables end if is1%beg = -1; is2%beg = 0; is3%beg = 0 is1%end = m; is2%end = n; is3%end = p !allocate(qL_prim_rsx_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) !allocate(qR_prim_rsx_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) allocate (flux_rsx_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_gsrc_rsx_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_src_rsx_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsx_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if(qbmm) then allocate(mom_sp_rsx_vf_flat(is1%beg:is1%end+1,is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if(any(Re_size > 0)) then allocate (Re_avg_rsx_vf_flat(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(qL_prim_rsy_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) !allocate(qR_prim_rsy_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) allocate (flux_rsy_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_gsrc_rsy_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_src_rsy_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsy_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if(qbmm) then allocate(mom_sp_rsy_vf_flat(is1%beg:is1%end+1,is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if(any(Re_size > 0)) then allocate (Re_avg_rsy_vf_flat(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(qL_prim_rsz_vf_flat(is1%beg:is1%end, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) !allocate(qR_prim_rsz_vf_flat(is1%beg + 1:is1%end + 1, is2%beg:is2%end, is3%beg:is3%end, 1:sys_size)) allocate (flux_rsz_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_gsrc_rsz_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:sys_size)) allocate (flux_src_rsz_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, advxb:sys_size)) allocate (vel_src_rsz_vf_flat(is1%beg:is1%end, & is2%beg:is2%end, & is3%beg:is3%end, 1:num_dims)) if(qbmm) then allocate(mom_sp_rsz_vf_flat(is1%beg:is1%end+1,is2%beg:is2%end, is3%beg:is3%end, 1:4)) end if if(any(Re_size > 0)) then allocate (Re_avg_rsz_vf_flat(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_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, dqL_prim_dx_vf, & dqL_prim_dy_vf, & dqL_prim_dz_vf, & qL_prim_vf, & qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat, dqR_prim_dx_vf, & dqR_prim_dy_vf, & dqR_prim_dz_vf, & qR_prim_vf, & norm_dir, ix, iy, iz) real(kind(0d0)), dimension(startx:, starty:, startz:, 1:), intent(INOUT) :: qL_prim_rsx_vf_flat, qL_prim_rsy_vf_flat, qL_prim_rsz_vf_flat, qR_prim_rsx_vf_flat, qR_prim_rsy_vf_flat, qR_prim_rsz_vf_flat 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 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 = (/1d0, 0d0, 0d0/) elseif (norm_dir == 2) then is1 = iy; is2 = ix; is3 = iz dir_idx = (/2, 1, 3/); dir_flg = (/0d0, 1d0, 0d0/) else is1 = iz; is2 = iy; is3 = ix dir_idx = (/3, 1, 2/); dir_flg = (/0d0, 0d0, 1d0/) end if isx = ix; isy = iy; isz = iz !$acc update device(is1, is2, is3, dir_idx, dir_flg, isx, isy, isz) ! Population of Buffers in x-direction ============================= if (norm_dir == 1) then if (bc_x%beg == -4) 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_flat(-1, k, l, i) = & qR_prim_rsx_vf_flat(0, k, l, i) end do end do end do if (any(Re_size > 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_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 == -4) 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_flat(m + 1, k, l, i) = & qL_prim_rsx_vf_flat(m, k, l, i) end do end do end do if (any(Re_size > 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_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 == -4) 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_flat(-1, k, l, i) = & qR_prim_rsy_vf_flat(0, k, l, i) end do end do end do if (any(Re_size > 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_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 == -4) 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_flat(n+1, k, l, i) = & qL_prim_rsy_vf_flat(n, k, l, i) end do end do end do if (any(Re_size > 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_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 == -4) 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_flat(-1, k, l, i) = & qR_prim_rsz_vf_flat(0, k, l, i) end do end do end do if (any(Re_size > 0)) 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 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 == -4) 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_flat(p + 1, k, l, i) = & qL_prim_rsz_vf_flat(p, k, l, i) end do end do end do if (any(Re_size > 0)) 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 ! ----------- !> 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 (norm_dir == 1) then if (any(Re_size > 0)) 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) = 0d0 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_flat(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 (any(Re_size > 0)) 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) = 0d0 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_flat(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 (any(Re_size > 0)) 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) = 0d0 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_flat(j, k, l, i) = mom_sp(i)%sf(l, k, j) end do end do end do end do end if end if ! ================================================================== end subroutine s_initialize_riemann_solver ! --------------------------- !> The goal of this subroutine is to evaluate and account !! for the contribution of viscous stresses in the source !! flux for the momentum and energy. !! @param velL_vf Left, WENO reconstructed, cell-boundary values of the velocity !! @param velR_vf Right, WENO reconstructed, cell-boundary values of the velocity !! @param dvelL_dx_vf Left, WENO reconstructed cell-avg. x-dir derivative of the velocity !! @param dvelL_dy_vf Left, WENO reconstructed cell-avg. y-dir derivative of the velocity !! @param dvelL_dz_vf Left, WENO reconstructed cell-avg. z-dir derivative of the velocity !! @param dvelR_dx_vf Right, WENO reconstructed cell-avg. x-dir derivative of the velocity !! @param dvelR_dy_vf Right, WENO reconstructed cell-avg. y-dir derivative of the velocity !! @param dvelR_dz_vf Right, WENO reconstructed cell-avg. z-dir derivative of the velocity !! @param flux_src_vf Intercell flux !! @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_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, & 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 ! Arithmetic mean of the left and right, WENO-reconstructed, cell- ! boundary values of cell-average first-order spatial derivatives ! of velocity real(kind(0d0)), dimension(num_dims) :: avg_vel real(kind(0d0)), dimension(num_dims) :: dvel_avg_dx real(kind(0d0)), dimension(num_dims) :: dvel_avg_dy real(kind(0d0)), dimension(num_dims) :: dvel_avg_dz ! Viscous stress tensor real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re ! Generic loop iterators integer :: i, j, k, l ! Viscous Stresses in z-direction ================================== if (norm_dir == 1) then if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & Re_avg_rsx_vf_flat(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dx(1)/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (n == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(2) = 5d-1*(velL_vf(2)%sf(j, k, l) & + velR_vf(2)%sf(j + 1, k, l)) !$acc loop seq do i = 1, 2 dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j + 1, k, l)) end do dvel_avg_dx(2) = 5d-1*(dvelL_dx_vf(2)%sf(j, k, l) & + dvelR_dx_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*(dvel_avg_dy(2) + & avg_vel(2)/y_cc(k))/ & Re_avg_rsx_vf_flat(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsx_vf_flat(j, k, l, 1) !$acc loop seq do i = 1, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(1, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, i)* & tau_Re(1, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(2) = 5d-1*(velL_vf(2)%sf(j, k, l) & + velR_vf(2)%sf(j + 1, k, l)) dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = (dvel_avg_dy(2) + & avg_vel(2)/y_cc(k))/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (p == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 1, 3, 2 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j + 1, k, l)) end do dvel_avg_dx(3) = 5d-1*(dvelL_dx_vf(3)%sf(j, k, l) & + dvelR_dx_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/y_cc(k)/ & Re_avg_rsx_vf_flat(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1)/y_cc(k) + dvel_avg_dx(3))/ & Re_avg_rsx_vf_flat(j, k, l, 1) !$acc loop seq do i = 1, 3, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(1, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, i)* & tau_Re(1, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( avg_vel, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dz(3)/y_cc(k)/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if ! END: Viscous Stresses in z-direction ============================= ! Viscous Stresses in r-direction ================================== elseif (norm_dir == 2) then if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(2) = 5d-1*(velL_vf(2)%sf(j, k, l) & + velR_vf(2)%sf(j, k + 1, l)) !$acc loop seq do i = 1, 2 dvel_avg_dx(i) = & 5d-1*(dvelL_dx_vf(i)%sf(j, k, l) & + dvelR_dx_vf(i)%sf(j, k + 1, l)) dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j, k + 1, l)) end do tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsy_vf_flat(k, j, l, 1) tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - 2d0*dvel_avg_dx(1) & - 2d0*avg_vel(2)/y_cb(k))/ & (3d0*Re_avg_rsy_vf_flat(k, j, l, 1)) !$acc loop seq do i = 1, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(2, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, i)* & tau_Re(2, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(2) = 5d-1*(velL_vf(2)%sf(j, k, l) & + velR_vf(2)%sf(j, k + 1, l)) dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j, k + 1, l)) dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j, k + 1, l)) tau_Re(2, 2) = (dvel_avg_dx(1) + dvel_avg_dy(2) + & avg_vel(2)/y_cb(k))/ & Re_avg_rsy_vf_flat(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & tau_Re(2, 2) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, 2)* & tau_Re(2, 2) end do end do end do end if if (p == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(3) = 5d-1*(velL_vf(3)%sf(j, k, l) & + velR_vf(3)%sf(j, k + 1, l)) !$acc loop seq do i = 2, 3 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j, k + 1, l)) end do dvel_avg_dy(3) = 5d-1*(dvelL_dy_vf(3)%sf(j, k, l) & + dvelR_dy_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/y_cb(k)/ & Re_avg_rsy_vf_flat(k, j, l, 1) tau_Re(2, 3) = ((dvel_avg_dz(2) - avg_vel(3))/ & y_cb(k) + dvel_avg_dy(3))/ & Re_avg_rsy_vf_flat(k, j, l, 1) !$acc loop seq do i = 2, 3 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(2, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, i)* & tau_Re(2, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = dvel_avg_dz(3)/y_cb(k)/ & Re_avg_rsy_vf_flat(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & tau_Re(2, 2) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, 2)* & tau_Re(2, 2) end do end do end do end if ! END: Viscous Stresses in r-direction ============================= ! Viscous Stresses in theta-direction ================================== else if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 2, 3 avg_vel(i) = 5d-1*(velL_vf(i)%sf(j, k, l) & + velR_vf(i)%sf(j, k, l + 1)) end do !$acc loop seq do i = 1, 3, 2 dvel_avg_dx(i) = & 5d-1*(dvelL_dx_vf(i)%sf(j, k, l) & + dvelR_dx_vf(i)%sf(j, k, l + 1)) end do do i = 2, 3 dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j, k, l + 1)) end do !$acc loop seq do i = 1, 3 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j, k, l + 1)) end do tau_Re(3, 1) = (dvel_avg_dz(1)/y_cc(k) + dvel_avg_dx(3))/ & Re_avg_rsz_vf_flat(l, k, j, 1)/ & y_cc(k) tau_Re(3, 2) = ((dvel_avg_dz(2) - avg_vel(3))/ & y_cc(k) + dvel_avg_dy(3))/ & Re_avg_rsz_vf_flat(l, k, j, 1)/ & y_cc(k) tau_Re(3, 3) = (4d0*dvel_avg_dz(3)/y_cc(k) & - 2d0*dvel_avg_dx(1) & - 2d0*dvel_avg_dy(2) & + 4d0*avg_vel(2)/y_cc(k))/ & (3d0*Re_avg_rsz_vf_flat(l, k, j, 1))/ & y_cc(k) !$acc loop seq do i = 1, 3 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(3, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsz_vf_flat(l, k, j, i)* & tau_Re(3, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private(avg_vel, dvel_avg_dx, dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end avg_vel(2) = 5d-1*(velL_vf(2)%sf(j, k, l) & + velR_vf(2)%sf(j, k, l + 1)) dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j, k, l + 1)) dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j, k, l + 1)) dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j, k, l + 1)) tau_Re(3, 3) = (dvel_avg_dx(1) & + dvel_avg_dy(2) & + dvel_avg_dz(3)/y_cc(k) & + avg_vel(2)/y_cc(k))/ & Re_avg_rsz_vf_flat(l, k, j, 2)/ & y_cc(k) flux_src_vf(momxe)%sf(j, k, l) = & flux_src_vf(momxe)%sf(j, k, l) - & tau_Re(3, 3) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsz_vf_flat(l, k, j, 3)* & tau_Re(3, 3) end do end do end do end if end if ! END: Viscous Stresses in theta-direction ============================= end subroutine s_compute_cylindrical_viscous_source_flux ! ------------------------- !> The goal of this subroutine is to evaluate and account !! for the contribution of viscous stresses in the source !! flux for the momentum and energy. !! @param velL_vf Left, WENO reconstructed, cell-boundary values of the velocity !! @param velR_vf Right, WENO reconstructed, cell-boundary values of the velocity !! @param dvelL_dx_vf Left, WENO reconstructed cell-avg. x-dir derivative of the velocity !! @param dvelL_dy_vf Left, WENO reconstructed cell-avg. y-dir derivative of the velocity !! @param dvelL_dz_vf Left, WENO reconstructed cell-avg. z-dir derivative of the velocity !! @param dvelR_dx_vf Right, WENO reconstructed cell-avg. x-dir derivative of the velocity !! @param dvelR_dy_vf Right, WENO reconstructed cell-avg. y-dir derivative of the velocity !! @param dvelR_dz_vf Right, WENO reconstructed cell-avg. z-dir derivative of the velocity !! @param flux_src_vf Intercell flux !! @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_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) type(scalar_field), & dimension(num_dims), & 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 ! Arithmetic mean of the left and right, WENO-reconstructed, cell- ! boundary values of cell-average first-order spatial derivatives ! of velocity real(kind(0d0)), dimension(num_dims) :: dvel_avg_dx real(kind(0d0)), dimension(num_dims) :: dvel_avg_dy real(kind(0d0)), dimension(num_dims) :: dvel_avg_dz real(kind(0d0)), dimension(num_dims, num_dims) :: tau_Re !< Viscous stress tensor integer :: i, j, k, l !< Generic loop iterators ! Viscous Stresses in x-direction ================================== if (norm_dir == 1) then if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = (4d0/3d0)*dvel_avg_dx(1)/ & Re_avg_rsx_vf_flat(j, k, l, 1) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dx(1)/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (n == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private(dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 1, 2 dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j + 1, k, l)) end do dvel_avg_dx(2) = 5d-1*(dvelL_dx_vf(2)%sf(j, k, l) & + dvelR_dx_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dy(2)/ & Re_avg_rsx_vf_flat(j, k, l, 1) tau_Re(1, 2) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsx_vf_flat(j, k, l, 1) !$acc loop seq do i = 1, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(1, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, i)* & tau_Re(1, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dy(2)/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if if (p == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 1, 3, 2 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j + 1, k, l)) end do dvel_avg_dx(3) = 5d-1*(dvelL_dx_vf(3)%sf(j, k, l) & + dvelR_dx_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = -(2d0/3d0)*dvel_avg_dz(3)/ & Re_avg_rsx_vf_flat(j, k, l, 1) tau_Re(1, 3) = (dvel_avg_dz(1) + dvel_avg_dx(3))/ & Re_avg_rsx_vf_flat(j, k, l, 1) !$acc loop seq do i = 1, 3, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(1, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, i)* & tau_Re(1, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j + 1, k, l)) tau_Re(1, 1) = dvel_avg_dz(3)/ & Re_avg_rsx_vf_flat(j, k, l, 2) flux_src_vf(momxb)%sf(j, k, l) = & flux_src_vf(momxb)%sf(j, k, l) - & tau_Re(1, 1) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsx_vf_flat(j, k, l, 1)* & tau_Re(1, 1) end do end do end do end if ! END: Viscous Stresses in x-direction ============================= ! Viscous Stresses in y-direction ================================== elseif (norm_dir == 2) then if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 1, 2 dvel_avg_dx(i) = & 5d-1*(dvelL_dx_vf(i)%sf(j, k, l) & + dvelR_dx_vf(i)%sf(j, k + 1, l)) dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j, k + 1, l)) end do tau_Re(2, 1) = (dvel_avg_dy(1) + dvel_avg_dx(2))/ & Re_avg_rsy_vf_flat(k, j, l, 1) tau_Re(2, 2) = (4d0*dvel_avg_dy(2) & - 2d0*dvel_avg_dx(1))/ & (3d0*Re_avg_rsy_vf_flat(k, j, l, 1)) !$acc loop seq do i = 1, 2 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(2, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, i)* & tau_Re(2, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, dvel_avg_dy, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j, k + 1, l)) dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j, k + 1, l)) tau_Re(2, 2) = (dvel_avg_dx(1) + dvel_avg_dy(2))/ & Re_avg_rsy_vf_flat(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & tau_Re(2, 2) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, 2)* & tau_Re(2, 2) end do end do end do end if if (p == 0) return if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 2, 3 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j, k + 1, l)) end do dvel_avg_dy(3) = 5d-1*(dvelL_dy_vf(3)%sf(j, k, l) & + dvelR_dy_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = -(2d0/3d0)*dvel_avg_dz(3)/ & Re_avg_rsy_vf_flat(k, j, l, 1) tau_Re(2, 3) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & Re_avg_rsy_vf_flat(k, j, l, 1) !$acc loop seq do i = 2, 3 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(2, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, i)* & tau_Re(2, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j, k + 1, l)) tau_Re(2, 2) = dvel_avg_dz(3)/ & Re_avg_rsy_vf_flat(k, j, l, 2) flux_src_vf(momxb + 1)%sf(j, k, l) = & flux_src_vf(momxb + 1)%sf(j, k, l) - & tau_Re(2, 2) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsy_vf_flat(k, j, l, 2)* & tau_Re(2, 2) end do end do end do end if ! END: Viscous Stresses in y-direction ============================= ! Viscous Stresses in z-direction ================================== else if (Re_size(1) > 0) then ! Shear stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end !$acc loop seq do i = 1, 3, 2 dvel_avg_dx(i) = & 5d-1*(dvelL_dx_vf(i)%sf(j, k, l) & + dvelR_dx_vf(i)%sf(j, k, l + 1)) end do !$acc loop seq do i = 2, 3 dvel_avg_dy(i) = & 5d-1*(dvelL_dy_vf(i)%sf(j, k, l) & + dvelR_dy_vf(i)%sf(j, k, l + 1)) end do !$acc loop seq do i = 1, 3 dvel_avg_dz(i) = & 5d-1*(dvelL_dz_vf(i)%sf(j, k, l) & + dvelR_dz_vf(i)%sf(j, k, l + 1)) end do tau_Re(3, 1) = (dvel_avg_dz(1) + dvel_avg_dx(3))/ & Re_avg_rsz_vf_flat(l, k, j, 1) tau_Re(3, 2) = (dvel_avg_dz(2) + dvel_avg_dy(3))/ & Re_avg_rsz_vf_flat(l, k, j, 1) tau_Re(3, 3) = (4d0*dvel_avg_dz(3) & - 2d0*dvel_avg_dx(1) & - 2d0*dvel_avg_dy(2))/ & (3d0*Re_avg_rsz_vf_flat(l, k, j, 1)) !$acc loop seq do i = 1, 3 flux_src_vf(contxe + i)%sf(j, k, l) = & flux_src_vf(contxe + i)%sf(j, k, l) - & tau_Re(3, i) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsz_vf_flat(l, k, j, i)* & tau_Re(3, i) end do end do end do end do end if if (Re_size(2) > 0) then ! Bulk stresses !$acc parallel loop collapse(3) gang vector default(present) private( dvel_avg_dx, dvel_avg_dy, dvel_avg_dz, tau_Re) do l = isz%beg, isz%end do k = isy%beg, isy%end do j = isx%beg, isx%end dvel_avg_dx(1) = 5d-1*(dvelL_dx_vf(1)%sf(j, k, l) & + dvelR_dx_vf(1)%sf(j, k, l + 1)) dvel_avg_dy(2) = 5d-1*(dvelL_dy_vf(2)%sf(j, k, l) & + dvelR_dy_vf(2)%sf(j, k, l + 1)) dvel_avg_dz(3) = 5d-1*(dvelL_dz_vf(3)%sf(j, k, l) & + dvelR_dz_vf(3)%sf(j, k, l + 1)) tau_Re(3, 3) = (dvel_avg_dx(1) & + dvel_avg_dy(2) & + dvel_avg_dz(3))/ & Re_avg_rsz_vf_flat(l, k, j, 2) flux_src_vf(momxe)%sf(j, k, l) = & flux_src_vf(momxe)%sf(j, k, l) - & tau_Re(3, 3) flux_src_vf(E_idx)%sf(j, k, l) = & flux_src_vf(E_idx)%sf(j, k, l) - & vel_src_rsz_vf_flat(l, k, j, 3)* & tau_Re(3, 3) end do end do end do end if end if ! END: Viscous Stresses in z-direction ============================= end subroutine s_compute_cartesian_viscous_source_flux ! ------------------------- !> 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 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_flat(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_flat(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_flat(j, k, l, advxb) end do end do end do if (riemann_solver == 1) then !$acc parallel loop collapse(4) gang vector default(present) do i = advxb + 1, sys_size 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_flat(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 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_flat(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_flat(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_flat(j, k, l, advxb) end do end do end do if (riemann_solver == 1) then !$acc parallel loop collapse(4) gang vector default(present) do i = advxb + 1, sys_size 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_flat(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_flat(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_flat(j, k, l, advxb) end do end do end do if (riemann_solver == 1) then !$acc parallel loop collapse(4) gang vector default(present) do i = advxb + 1, sys_size 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) = & flux_src_rsx_vf_flat(j, k, l, i) end do end do end do end do end if end if ! ================================================================== ! ================================================================== end subroutine s_finalize_riemann_solver ! ----------------------------- !> Module deallocation and/or disassociation procedures subroutine s_finalize_riemann_solvers_module() ! ----------------------- ! Deallocating the variables that were utilized to formulate the ! left, right and average states of the Riemann problem, as well ! the Riemann problem solution integer :: i deallocate (vel_avg) if (riemann_solver == 3) then deallocate (alpha_rho_IC, vel_IC) deallocate (alpha_IC) end if if (bubbles) then if (qbmm) then deallocate (moms_L, moms_R) end if deallocate (R0_L, R0_R, pbw_L, pbw_R) deallocate (V0_L, V0_R) end if deallocate(gammas, pi_infs) ! Disassociating procedural pointer to the subroutine which was ! utilized to calculate the solution of a given Riemann problem s_riemann_solver => null() ! Disassociating the procedural pointers to the procedures that were ! utilized to compute the average state and estimate the wave speeds s_compute_average_state => null(); s_compute_wave_speeds => null() ! Disassociating procedural pointer to the subroutine which was ! utilized to calculate the viscous source flux s_compute_viscous_source_flux => null() ! Disassociating the pointer to the procedure that was utilized to ! to convert mixture or species variables to the mixture variables s_convert_to_mixture_variables => null() if(Re_size(1) > 0) then deallocate(Re_avg_rsx_vf_flat) end if deallocate(vel_src_rsx_vf_flat) deallocate(flux_rsx_vf_flat) deallocate(flux_src_rsx_vf_flat) deallocate(flux_gsrc_rsx_vf_flat) if(qbmm) then deallocate(mom_sp_rsx_vf_flat) end if !deallocate(qL_prim_rsx_vf_flat) !deallocate(qR_prim_rsx_vf_flat) if(n == 0) return if(Re_size(1) > 0) then deallocate(Re_avg_rsy_vf_flat) end if deallocate(vel_src_rsy_vf_flat) deallocate(flux_rsy_vf_flat) deallocate(flux_src_rsy_vf_flat) deallocate(flux_gsrc_rsy_vf_flat) if(qbmm) then deallocate(mom_sp_rsy_vf_flat) end if !deallocate(qL_prim_rsy_vf_flat) !deallocate(qR_prim_rsy_vf_flat) if(p == 0) return if(Re_size(1) > 0) then deallocate(Re_avg_rsz_vf_flat) end if deallocate(vel_src_rsz_vf_flat) deallocate(flux_rsz_vf_flat) deallocate(flux_src_rsz_vf_flat) deallocate(flux_gsrc_rsz_vf_flat) if(qbmm) then deallocate(mom_sp_rsz_vf_flat) end if !deallocate(qL_prim_rsz_vf_flat) !deallocate(qR_prim_rsz_vf_flat) end subroutine s_finalize_riemann_solvers_module ! --------------------- end module m_riemann_solvers