From e0036ca39eff82ea6feb42c7c38c84f4f60a2a05 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 00:17:52 -0400 Subject: [PATCH 01/11] src: bundle post_process finite-difference state into fd_context --- src/common/m_derived_types.fpp | 9 +++ src/post_process/m_derived_variables.fpp | 88 +++++++++++------------- src/post_process/m_start_up.fpp | 6 +- 3 files changed, 53 insertions(+), 50 deletions(-) diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 0c4ea95872..90a8b025d9 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -169,6 +169,15 @@ module m_derived_types #endif end type ic_context + !> Finite-difference state for post_process: density gradient magnitude for + !> numerical Schlieren and centered FD coefficients in x-, y-, and z-directions. + type fd_context + real(wp), allocatable, dimension(:,:,:) :: gm_rho_sf !< Density gradient magnitude for numerical Schlieren + real(wp), allocatable, dimension(:,:) :: fd_coeff_x !< FD coefficients in the x-direction + real(wp), allocatable, dimension(:,:) :: fd_coeff_y !< FD coefficients in the y-direction + real(wp), allocatable, dimension(:,:) :: fd_coeff_z !< FD coefficients in the z-direction + end type fd_context + type bc_patch_parameters integer :: geometry integer :: type diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 4145cab1a1..3da2dc13ed 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -17,17 +17,10 @@ module m_derived_variables private; public :: s_initialize_derived_variables_module, s_derive_specific_heat_ratio, s_derive_liquid_stiffness, & & s_derive_sound_speed, s_derive_flux_limiter, s_derive_vorticity_component, s_derive_qm, s_derive_liutex, & - & s_derive_numerical_schlieren_function, s_compute_speed_of_sound, s_finalize_derived_variables_module - - real(wp), allocatable, dimension(:,:,:) :: gm_rho_sf !< Density gradient magnitude for numerical Schlieren - !> @name Finite-difference (fd) coefficients in x-, y- and z-coordinate directions. Note that because sufficient boundary - !! information is available for all the active coordinate directions, the centered family of the finite-difference schemes is - !! used. - !> @{ - real(wp), allocatable, dimension(:,:), public :: fd_coeff_x - real(wp), allocatable, dimension(:,:), public :: fd_coeff_y - real(wp), allocatable, dimension(:,:), public :: fd_coeff_z - !> @} + & s_derive_numerical_schlieren_function, s_compute_speed_of_sound, s_finalize_derived_variables_module, fd + + !> Finite-difference state: density gradient magnitude and centered FD coefficients in x-, y-, and z-directions. + type(fd_context) :: fd contains @@ -36,21 +29,21 @@ contains ! Allocate density gradient magnitude if Schlieren output requested if (schlieren_wrt) then - allocate (gm_rho_sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) + allocate (fd%gm_rho_sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) end if ! Allocate FD coefficients (up to 4th order; higher orders need extension) if (omega_wrt(2) .or. omega_wrt(3) .or. schlieren_wrt .or. liutex_wrt) then - allocate (fd_coeff_x(-fd_number:fd_number,-offset_x%beg:m + offset_x%end)) + allocate (fd%fd_coeff_x(-fd_number:fd_number,-offset_x%beg:m + offset_x%end)) end if if (omega_wrt(1) .or. omega_wrt(3) .or. liutex_wrt .or. (n > 0 .and. schlieren_wrt)) then - allocate (fd_coeff_y(-fd_number:fd_number,-offset_y%beg:n + offset_y%end)) + allocate (fd%fd_coeff_y(-fd_number:fd_number,-offset_y%beg:n + offset_y%end)) end if if (omega_wrt(1) .or. omega_wrt(2) .or. liutex_wrt .or. (p > 0 .and. schlieren_wrt)) then - allocate (fd_coeff_z(-fd_number:fd_number,-offset_z%beg:p + offset_z%end)) + allocate (fd%fd_coeff_z(-fd_number:fd_number,-offset_z%beg:p + offset_z%end)) end if end subroutine s_initialize_derived_variables_module @@ -219,12 +212,12 @@ contains do r = -fd_number, fd_number if (grid_geometry == 3) then - q_sf(j, k, l) = q_sf(j, k, l) + 1._wp/y_cc(k)*(fd_coeff_y(r, & - & k)*y_cc(r + k)*q_prim_vf(eqn_idx%mom%end)%sf(j, r + k, l) - fd_coeff_z(r, & + q_sf(j, k, l) = q_sf(j, k, l) + 1._wp/y_cc(k)*(fd%fd_coeff_y(r, & + & k)*y_cc(r + k)*q_prim_vf(eqn_idx%mom%end)%sf(j, r + k, l) - fd%fd_coeff_z(r, & & l)*q_prim_vf(eqn_idx%mom%beg + 1)%sf(j, k, r + l)) else - q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%end)%sf(j, r + k, & - & l) - fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg + 1)%sf(j, k, r + l) + q_sf(j, k, l) = q_sf(j, k, l) + fd%fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%end)%sf(j, r + k, & + & l) - fd%fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg + 1)%sf(j, k, r + l) end if end do end do @@ -238,11 +231,11 @@ contains do r = -fd_number, fd_number if (grid_geometry == 3) then - q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_z(r, l)/y_cc(k)*q_prim_vf(eqn_idx%mom%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%end)%sf(r + j, k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd%fd_coeff_z(r, l)/y_cc(k)*q_prim_vf(eqn_idx%mom%beg)%sf(j, k, & + & r + l) - fd%fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%end)%sf(r + j, k, l) else - q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg)%sf(j, k, & - & r + l) - fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%end)%sf(r + j, k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd%fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg)%sf(j, k, & + & r + l) - fd%fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%end)%sf(r + j, k, l) end if end do end do @@ -255,8 +248,8 @@ contains q_sf(j, k, l) = 0._wp do r = -fd_number, fd_number - q_sf(j, k, l) = q_sf(j, k, l) + fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%beg + 1)%sf(r + j, k, & - & l) - fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%beg)%sf(j, r + k, l) + q_sf(j, k, l) = q_sf(j, k, l) + fd%fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%beg + 1)%sf(r + j, k, & + & l) - fd%fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%beg)%sf(j, r + k, l) end do end do end do @@ -286,13 +279,13 @@ contains do r = -fd_number, fd_number do jj = 1, 3 ! d()/dx - q_jacobian_sf(jj, 1) = q_jacobian_sf(jj, 1) + fd_coeff_x(r, & + q_jacobian_sf(jj, 1) = q_jacobian_sf(jj, 1) + fd%fd_coeff_x(r, & & j)*q_prim_vf(eqn_idx%mom%beg + jj - 1)%sf(r + j, k, l) ! d()/dy - q_jacobian_sf(jj, 2) = q_jacobian_sf(jj, 2) + fd_coeff_y(r, & + q_jacobian_sf(jj, 2) = q_jacobian_sf(jj, 2) + fd%fd_coeff_y(r, & & k)*q_prim_vf(eqn_idx%mom%beg + jj - 1)%sf(j, r + k, l) ! d()/dz - q_jacobian_sf(jj, 3) = q_jacobian_sf(jj, 3) + fd_coeff_z(r, & + q_jacobian_sf(jj, 3) = q_jacobian_sf(jj, 3) + fd%fd_coeff_z(r, & & l)*q_prim_vf(eqn_idx%mom%beg + jj - 1)%sf(j, k, r + l) end do end do @@ -364,11 +357,11 @@ contains do r = -fd_number, fd_number do i = 1, 3 ! d()/dx - vgt(i, 1) = vgt(i, 1) + fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(r + j, k, l) + vgt(i, 1) = vgt(i, 1) + fd%fd_coeff_x(r, j)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(r + j, k, l) ! d()/dy - vgt(i, 2) = vgt(i, 2) + fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(j, r + k, l) + vgt(i, 2) = vgt(i, 2) + fd%fd_coeff_y(r, k)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(j, r + k, l) ! d()/dz - vgt(i, 3) = vgt(i, 3) + fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, r + l) + vgt(i, 3) = vgt(i, 3) + fd%fd_coeff_z(r, l)*q_prim_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, r + l) end do end do @@ -449,11 +442,11 @@ contains drho_dy = 0._wp do i = -fd_number, fd_number - drho_dx = drho_dx + fd_coeff_x(i, j)*rho_sf(i + j, k, l) - drho_dy = drho_dy + fd_coeff_y(i, k)*rho_sf(j, i + k, l) + drho_dx = drho_dx + fd%fd_coeff_x(i, j)*rho_sf(i + j, k, l) + drho_dy = drho_dy + fd%fd_coeff_y(i, k)*rho_sf(j, i + k, l) end do - gm_rho_sf(j, k, l) = drho_dx*drho_dx + drho_dy*drho_dy + fd%gm_rho_sf(j, k, l) = drho_dx*drho_dx + drho_dy*drho_dy end do end do end do @@ -466,21 +459,21 @@ contains do i = -fd_number, fd_number if (grid_geometry == 3) then - drho_dz = drho_dz + fd_coeff_z(i, l)/y_cc(k)*rho_sf(j, k, i + l) + drho_dz = drho_dz + fd%fd_coeff_z(i, l)/y_cc(k)*rho_sf(j, k, i + l) else - drho_dz = drho_dz + fd_coeff_z(i, l)*rho_sf(j, k, i + l) + drho_dz = drho_dz + fd%fd_coeff_z(i, l)*rho_sf(j, k, i + l) end if end do - gm_rho_sf(j, k, l) = gm_rho_sf(j, k, l) + drho_dz*drho_dz + fd%gm_rho_sf(j, k, l) = fd%gm_rho_sf(j, k, l) + drho_dz*drho_dz end do end do end do end if - gm_rho_sf = sqrt(gm_rho_sf) + fd%gm_rho_sf = sqrt(fd%gm_rho_sf) - gm_rho_max = (/maxval(gm_rho_sf), real(proc_rank, wp)/) + gm_rho_max = (/maxval(fd%gm_rho_sf), real(proc_rank, wp)/) if (num_procs > 1) call s_mpi_reduce_maxloc(gm_rho_max) @@ -490,7 +483,7 @@ contains ! function is evaluated. For more information, refer to Marquina and Mulet (2003). if (model_eqns == model_eqns_gamma_law) then ! Gamma/pi_inf model - q_sf = -gm_rho_sf/gm_rho_max(1) + q_sf = -fd%gm_rho_sf/gm_rho_max(1) else ! Volume fraction model do l = -offset_z%beg, p + offset_z%end do k = -offset_y%beg, n + offset_y%end @@ -505,14 +498,15 @@ contains alpha_last = 1._wp do i = 1, eqn_idx%adv%end - eqn_idx%E q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(i)*q_cons_vf(i + eqn_idx%E)%sf(j, k, & - & l)*gm_rho_sf(j, k, l)/gm_rho_max(1) + & l)*fd%gm_rho_sf(j, k, l)/gm_rho_max(1) alpha_last = alpha_last - q_cons_vf(i + eqn_idx%E)%sf(j, k, l) end do - q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(num_fluids)*alpha_last*gm_rho_sf(j, k, l)/gm_rho_max(1) + q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(num_fluids)*alpha_last*fd%gm_rho_sf(j, k, & + & l)/gm_rho_max(1) else do i = 1, eqn_idx%adv%end - eqn_idx%E q_sf(j, k, l) = q_sf(j, k, l) - schlieren_alpha(i)*q_cons_vf(i + eqn_idx%E)%sf(j, k, & - & l)*gm_rho_sf(j, k, l)/gm_rho_max(1) + & l)*fd%gm_rho_sf(j, k, l)/gm_rho_max(1) end do end if end do @@ -531,13 +525,13 @@ contains ! Deallocating the variable containing the gradient magnitude of the density field provided that the numerical Schlieren ! function was was outputted during the post-process - if (schlieren_wrt) deallocate (gm_rho_sf) + if (schlieren_wrt) deallocate (fd%gm_rho_sf) ! Deallocating the variables that might have been used to bookkeep the finite-difference coefficients in the x-, y- and ! z-directions - if (allocated(fd_coeff_x)) deallocate (fd_coeff_x) - if (allocated(fd_coeff_y)) deallocate (fd_coeff_y) - if (allocated(fd_coeff_z)) deallocate (fd_coeff_z) + if (allocated(fd%fd_coeff_x)) deallocate (fd%fd_coeff_x) + if (allocated(fd%fd_coeff_y)) deallocate (fd%fd_coeff_y) + if (allocated(fd%fd_coeff_z)) deallocate (fd%fd_coeff_z) end subroutine s_finalize_derived_variables_module diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index 9d0ad71c88..a917d25239 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -214,15 +214,15 @@ contains call s_write_grid_to_formatted_database_file(t_step) if (omega_wrt(2) .or. omega_wrt(3) .or. qm_wrt .or. liutex_wrt .or. schlieren_wrt) then - call s_compute_finite_difference_coefficients(m, x_cc, fd_coeff_x, buff_size, fd_number, fd_order, offset_x) + call s_compute_finite_difference_coefficients(m, x_cc, fd%fd_coeff_x, buff_size, fd_number, fd_order, offset_x) end if if (omega_wrt(1) .or. omega_wrt(3) .or. qm_wrt .or. liutex_wrt .or. (n > 0 .and. schlieren_wrt)) then - call s_compute_finite_difference_coefficients(n, y_cc, fd_coeff_y, buff_size, fd_number, fd_order, offset_y) + call s_compute_finite_difference_coefficients(n, y_cc, fd%fd_coeff_y, buff_size, fd_number, fd_order, offset_y) end if if (omega_wrt(1) .or. omega_wrt(2) .or. qm_wrt .or. liutex_wrt .or. (p > 0 .and. schlieren_wrt)) then - call s_compute_finite_difference_coefficients(p, z_cc, fd_coeff_z, buff_size, fd_number, fd_order, offset_z) + call s_compute_finite_difference_coefficients(p, z_cc, fd%fd_coeff_z, buff_size, fd_number, fd_order, offset_z) end if if ((model_eqns == model_eqns_5eq) .or. (model_eqns == model_eqns_6eq) .or. (model_eqns == model_eqns_4eq)) then From 3ad17bd5e8fa5efd97a47520bc0166f4cc8e59f2 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 02:55:32 -0400 Subject: [PATCH 02/11] src: bundle post_process output workspace into output_context --- src/common/m_derived_types.fpp | 31 ++ src/post_process/m_data_output.fpp | 443 +++++++++++++---------------- src/post_process/m_start_up.fpp | 84 +++--- 3 files changed, 278 insertions(+), 280 deletions(-) diff --git a/src/common/m_derived_types.fpp b/src/common/m_derived_types.fpp index 90a8b025d9..b90cc944e4 100644 --- a/src/common/m_derived_types.fpp +++ b/src/common/m_derived_types.fpp @@ -178,6 +178,37 @@ module m_derived_types real(wp), allocatable, dimension(:,:) :: fd_coeff_z !< FD coefficients in the z-direction end type fd_context + !> Output workspace for post_process: flow variable buffers, VisIt extents/offsets, + !> directory paths, Silo/Binary file handles, and variable count. + type output_context + ! Flow variable storage; q_root_sf gathers to rank 0 in 1D parallel runs + real(wp), allocatable, dimension(:,:,:) :: q_sf !< Working flow variable field (public) + real(wp), allocatable, dimension(:,:,:) :: q_root_sf !< Gathered 1D flow variable field (rank 0 only) + real(wp), allocatable, dimension(:,:,:) :: cyl_q_sf !< Cylindrical-geometry reordered field + ! Single precision storage for flow variables + real(sp), allocatable, dimension(:,:,:) :: q_sf_s !< Single-precision working field (public) + real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s !< Single-precision gathered 1D field + real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s !< Single-precision cylindrical reordered field + ! Spatial and data extents for VisIt visualization (Silo only) + real(wp), allocatable, dimension(:,:) :: spatial_extents !< Spatial extents per process + real(wp), allocatable, dimension(:,:) :: data_extents !< Data extents per process + ! Ghost zone layer sizes (lo/hi) for subdomain connectivity in VisIt (Silo only) + integer, allocatable, dimension(:) :: lo_offset !< Ghost zone lo sizes per active direction + integer, allocatable, dimension(:) :: hi_offset !< Ghost zone hi sizes per active direction + ! Cell-boundary count per active coordinate direction (Silo only) + integer, allocatable, dimension(:) :: dims !< Cell-boundary counts per active direction + ! Formatted database directory paths + character(LEN=path_len + name_len) :: dbdir !< Base database directory + character(LEN=path_len + 2*name_len) :: proc_rank_dir !< Per-rank subdirectory + character(LEN=path_len + 2*name_len) :: rootdir !< Root subdirectory + ! Formatted database file handles + integer :: dbroot !< Master/root file handle + integer :: dbfile !< Slave/local file handle + integer :: optlist !< Silo options list handle (per-call scratch) + ! Variable count for Binary format + integer :: dbvars !< Total flow variables to write + end type output_context + type bc_patch_parameters integer :: geometry integer :: type diff --git a/src/post_process/m_data_output.fpp b/src/post_process/m_data_output.fpp index 3b40026a7d..bb2de77a9b 100644 --- a/src/post_process/m_data_output.fpp +++ b/src/post_process/m_data_output.fpp @@ -21,56 +21,15 @@ module m_data_output & s_write_variable_to_formatted_database_file, s_write_lag_bubbles_results_to_text, & & s_write_lag_bubbles_to_formatted_database_file, s_write_ib_state_files, s_write_intf_data_file, & & s_write_energy_data_file, s_write_ib_bodies_to_formatted_database_file, s_close_formatted_database_file, & - & s_close_intf_data_file, s_close_energy_data_file, s_finalize_data_output_module + & s_close_intf_data_file, s_close_energy_data_file, s_finalize_data_output_module, out ! Include Silo-HDF5 interface library include 'silo_f9x.inc' - ! Flow variable storage; q_root_sf gathers to rank 0 in 1D parallel runs - real(wp), allocatable, dimension(:,:,:), public :: q_sf - real(wp), allocatable, dimension(:,:,:) :: q_root_sf - real(wp), allocatable, dimension(:,:,:) :: cyl_q_sf - - ! Single precision storage for flow variables - real(sp), allocatable, dimension(:,:,:), public :: q_sf_s - real(sp), allocatable, dimension(:,:,:) :: q_root_sf_s - real(sp), allocatable, dimension(:,:,:) :: cyl_q_sf_s - - ! Spatial and data extents for VisIt visualization - real(wp), allocatable, dimension(:,:) :: spatial_extents - real(wp), allocatable, dimension(:,:) :: data_extents - - ! Ghost zone layer sizes (lo/hi) for subdomain connectivity in VisIt - integer, allocatable, dimension(:) :: lo_offset - integer, allocatable, dimension(:) :: hi_offset - - ! Track cell-boundary count per active coordinate direction - integer, allocatable, dimension(:) :: dims - - ! Locations of various folders in the case's directory tree, associated with the choice of the formatted database format. These - ! include, in order, the location of the folder named after the selected formatted database format, and the locations of two - ! sub-directories of the latter, the first of which is named after the local processor rank, while the second is named 'root'. - ! The folder associated with the local processor rank contains only the data pertaining to the part of the domain taken care of - ! by the local processor. The root directory, on the other hand, will contain either the information about the connectivity - ! required to put the entire domain back together, or the actual data associated with the entire computational domain. This all - ! depends on dimensionality and the choice of the formatted database format. - character(LEN=path_len + name_len) :: dbdir - character(LEN=path_len + 2*name_len) :: proc_rank_dir - character(LEN=path_len + 2*name_len) :: rootdir - - ! Handles of the formatted database master/root file, slave/local processor file and options list. The list of options is - ! explicitly used in the Silo- HDF5 database format to provide additional details about the contents of a formatted database - ! file, such as the previously described spatial and data extents. - integer :: dbroot - integer :: dbfile - integer :: optlist - - ! The total number of flow variable(s) to be stored in a formatted database file. Note that this is only needed when using the - ! Binary format. - integer :: dbvars - - ! Generic error flags utilized in the handling, checking and the reporting of the input and output operations errors with a - ! formatted database file + !> Output workspace: flow variable buffers, VisIt extents/offsets, directory paths, file handles, and variable count. + type(output_context) :: out + + ! Generic error flag for Silo-HDF5 and Binary I/O operations integer, private :: err contains @@ -82,22 +41,23 @@ contains logical :: dir_check integer :: i - allocate (q_sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) + allocate (out%q_sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) if (grid_geometry == 3) then - allocate (cyl_q_sf(-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end,-offset_x%beg:m + offset_x%end)) + allocate (out%cyl_q_sf(-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end,-offset_x%beg:m + offset_x%end)) end if if (precision == precision_single) then - allocate (q_sf_s(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) + allocate (out%q_sf_s(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end)) if (grid_geometry == 3) then - allocate (cyl_q_sf_s(-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end,-offset_x%beg:m + offset_x%end)) + allocate (out%cyl_q_sf_s(-offset_y%beg:n + offset_y%end,-offset_z%beg:p + offset_z%end, & + & -offset_x%beg:m + offset_x%end)) end if end if if (n == 0) then - allocate (q_root_sf(0:m_root,0:0,0:0)) + allocate (out%q_root_sf(0:m_root,0:0,0:0)) if (precision == precision_single) then - allocate (q_root_sf_s(0:m_root,0:0,0:0)) + allocate (out%q_root_sf_s(0:m_root,0:0,0:0)) end if end if @@ -105,23 +65,23 @@ contains ! cell-boundaries in each active coordinate direction. Note that all these variables are only needed by the Silo-HDF5 format ! for multidimensional data. if (format == format_silo) then - allocate (data_extents(1:2,0:num_procs - 1)) + allocate (out%data_extents(1:2,0:num_procs - 1)) if (p > 0) then - allocate (spatial_extents(1:6,0:num_procs - 1)) - allocate (lo_offset(1:3)) - allocate (hi_offset(1:3)) - allocate (dims(1:3)) + allocate (out%spatial_extents(1:6,0:num_procs - 1)) + allocate (out%lo_offset(1:3)) + allocate (out%hi_offset(1:3)) + allocate (out%dims(1:3)) else if (n > 0) then - allocate (spatial_extents(1:4,0:num_procs - 1)) - allocate (lo_offset(1:2)) - allocate (hi_offset(1:2)) - allocate (dims(1:2)) + allocate (out%spatial_extents(1:4,0:num_procs - 1)) + allocate (out%lo_offset(1:2)) + allocate (out%hi_offset(1:2)) + allocate (out%dims(1:2)) else - allocate (spatial_extents(1:2,0:num_procs - 1)) - allocate (lo_offset(1:1)) - allocate (hi_offset(1:1)) - allocate (dims(1:1)) + allocate (out%spatial_extents(1:2,0:num_procs - 1)) + allocate (out%lo_offset(1:1)) + allocate (out%hi_offset(1:1)) + allocate (out%dims(1:1)) end if end if @@ -132,92 +92,92 @@ contains if (format == format_silo) then if (p > 0) then if (grid_geometry == 3) then - lo_offset(:) = (/offset_y%beg, offset_z%beg, offset_x%beg/) - hi_offset(:) = (/offset_y%end, offset_z%end, offset_x%end/) + out%lo_offset(:) = (/offset_y%beg, offset_z%beg, offset_x%beg/) + out%hi_offset(:) = (/offset_y%end, offset_z%end, offset_x%end/) else - lo_offset(:) = (/offset_x%beg, offset_y%beg, offset_z%beg/) - hi_offset(:) = (/offset_x%end, offset_y%end, offset_z%end/) + out%lo_offset(:) = (/offset_x%beg, offset_y%beg, offset_z%beg/) + out%hi_offset(:) = (/offset_x%end, offset_y%end, offset_z%end/) end if if (grid_geometry == 3) then - dims(:) = (/n + offset_y%beg + offset_y%end + 2, p + offset_z%beg + offset_z%end + 2, & - & m + offset_x%beg + offset_x%end + 2/) + out%dims(:) = (/n + offset_y%beg + offset_y%end + 2, p + offset_z%beg + offset_z%end + 2, & + & m + offset_x%beg + offset_x%end + 2/) else - dims(:) = (/m + offset_x%beg + offset_x%end + 2, n + offset_y%beg + offset_y%end + 2, & - & p + offset_z%beg + offset_z%end + 2/) + out%dims(:) = (/m + offset_x%beg + offset_x%end + 2, n + offset_y%beg + offset_y%end + 2, & + & p + offset_z%beg + offset_z%end + 2/) end if else if (n > 0) then - lo_offset(:) = (/offset_x%beg, offset_y%beg/) - hi_offset(:) = (/offset_x%end, offset_y%end/) + out%lo_offset(:) = (/offset_x%beg, offset_y%beg/) + out%hi_offset(:) = (/offset_x%end, offset_y%end/) - dims(:) = (/m + offset_x%beg + offset_x%end + 2, n + offset_y%beg + offset_y%end + 2/) + out%dims(:) = (/m + offset_x%beg + offset_x%end + 2, n + offset_y%beg + offset_y%end + 2/) else - lo_offset(:) = (/offset_x%beg/) - hi_offset(:) = (/offset_x%end/) - dims(:) = (/m + offset_x%beg + offset_x%end + 2/) + out%lo_offset(:) = (/offset_x%beg/) + out%hi_offset(:) = (/offset_x%end/) + out%dims(:) = (/m + offset_x%beg + offset_x%end + 2/) end if end if if (format == format_silo) then - dbdir = trim(case_dir) // '/silo_hdf5' + out%dbdir = trim(case_dir) // '/silo_hdf5' - write (proc_rank_dir, '(A,I0)') '/p', proc_rank + write (out%proc_rank_dir, '(A,I0)') '/p', proc_rank - proc_rank_dir = trim(dbdir) // trim(proc_rank_dir) + out%proc_rank_dir = trim(out%dbdir) // trim(out%proc_rank_dir) - file_loc = trim(proc_rank_dir) // '/.' + file_loc = trim(out%proc_rank_dir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(proc_rank_dir)) + call s_create_directory(trim(out%proc_rank_dir)) end if if (proc_rank == 0) then - rootdir = trim(dbdir) // '/root' + out%rootdir = trim(out%dbdir) // '/root' - file_loc = trim(rootdir) // '/.' + file_loc = trim(out%rootdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(rootdir)) + call s_create_directory(trim(out%rootdir)) end if end if else - dbdir = trim(case_dir) // '/binary' + out%dbdir = trim(case_dir) // '/binary' - write (proc_rank_dir, '(A,I0)') '/p', proc_rank + write (out%proc_rank_dir, '(A,I0)') '/p', proc_rank - proc_rank_dir = trim(dbdir) // trim(proc_rank_dir) + out%proc_rank_dir = trim(out%dbdir) // trim(out%proc_rank_dir) - file_loc = trim(proc_rank_dir) // '/.' + file_loc = trim(out%proc_rank_dir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(proc_rank_dir)) + call s_create_directory(trim(out%proc_rank_dir)) end if if (n == 0 .and. proc_rank == 0) then - rootdir = trim(dbdir) // '/root' + out%rootdir = trim(out%dbdir) // '/root' - file_loc = trim(rootdir) // '/.' + file_loc = trim(out%rootdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(rootdir)) + call s_create_directory(trim(out%rootdir)) end if end if end if if (bubbles_lagrange) then ! Lagrangian solver if (lag_txt_wrt) then - dbdir = trim(case_dir) // '/lag_bubbles_post_process' - file_loc = trim(dbdir) // '/.' + out%dbdir = trim(case_dir) // '/lag_bubbles_post_process' + file_loc = trim(out%dbdir) // '/.' call my_inquire(file_loc, dir_check) if (dir_check .neqv. .true.) then - call s_create_directory(trim(dbdir)) + call s_create_directory(trim(out%dbdir)) end if end if end if @@ -226,91 +186,91 @@ contains ! perfectly static throughout post-process. Hence, they are set here so that they do not have to be repetitively computed in ! later procedures. if (format == format_binary) then - if (n == 0 .and. proc_rank == 0) dbroot = 2 - dbfile = 1 + if (n == 0 .and. proc_rank == 0) out%dbroot = 2 + out%dbfile = 1 end if if (format == format_binary) then - dbvars = 0 + out%dbvars = 0 if ((model_eqns == model_eqns_5eq) .or. (model_eqns == model_eqns_6eq)) then do i = 1, num_fluids if (alpha_rho_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if end do end if if ((rho_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) & & .and. (.not. relativity)) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if - if (relativity .and. (rho_wrt .or. prim_vars_wrt)) dbvars = dbvars + 1 - if (relativity .and. (rho_wrt .or. cons_vars_wrt)) dbvars = dbvars + 1 + if (relativity .and. (rho_wrt .or. prim_vars_wrt)) out%dbvars = out%dbvars + 1 + if (relativity .and. (rho_wrt .or. cons_vars_wrt)) out%dbvars = out%dbvars + 1 do i = 1, eqn_idx%E - eqn_idx%mom%beg - if (mom_wrt(i) .or. cons_vars_wrt) dbvars = dbvars + 1 + if (mom_wrt(i) .or. cons_vars_wrt) out%dbvars = out%dbvars + 1 end do do i = 1, eqn_idx%E - eqn_idx%mom%beg - if (vel_wrt(i) .or. prim_vars_wrt) dbvars = dbvars + 1 + if (vel_wrt(i) .or. prim_vars_wrt) out%dbvars = out%dbvars + 1 end do do i = 1, eqn_idx%E - eqn_idx%mom%beg - if (flux_wrt(i)) dbvars = dbvars + 1 + if (flux_wrt(i)) out%dbvars = out%dbvars + 1 end do - if (E_wrt .or. cons_vars_wrt) dbvars = dbvars + 1 - if (pres_wrt .or. prim_vars_wrt) dbvars = dbvars + 1 - if (hypoelasticity) dbvars = dbvars + (num_dims*(num_dims + 1))/2 - if (cont_damage) dbvars = dbvars + 1 - if (hyper_cleaning) dbvars = dbvars + 1 + if (E_wrt .or. cons_vars_wrt) out%dbvars = out%dbvars + 1 + if (pres_wrt .or. prim_vars_wrt) out%dbvars = out%dbvars + 1 + if (hypoelasticity) out%dbvars = out%dbvars + (num_dims*(num_dims + 1))/2 + if (cont_damage) out%dbvars = out%dbvars + 1 + if (hyper_cleaning) out%dbvars = out%dbvars + 1 if (mhd) then if (n == 0) then - dbvars = dbvars + 2 + out%dbvars = out%dbvars + 2 else - dbvars = dbvars + 3 + out%dbvars = out%dbvars + 3 end if end if if ((model_eqns == model_eqns_5eq) .or. (model_eqns == model_eqns_6eq)) then do i = 1, num_fluids - 1 if (alpha_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if end do if (alpha_wrt(num_fluids) .or. (cons_vars_wrt .or. prim_vars_wrt)) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if end if if (gamma_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if - if (heat_ratio_wrt) dbvars = dbvars + 1 + if (heat_ratio_wrt) out%dbvars = out%dbvars + 1 if (pi_inf_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) then - dbvars = dbvars + 1 + out%dbvars = out%dbvars + 1 end if - if (pres_inf_wrt) dbvars = dbvars + 1 - if (c_wrt) dbvars = dbvars + 1 + if (pres_inf_wrt) out%dbvars = out%dbvars + 1 + if (c_wrt) out%dbvars = out%dbvars + 1 if (p > 0) then do i = 1, num_vels - if (omega_wrt(i)) dbvars = dbvars + 1 + if (omega_wrt(i)) out%dbvars = out%dbvars + 1 end do else if (n > 0) then do i = 1, num_vels - if (omega_wrt(i)) dbvars = dbvars + 1 + if (omega_wrt(i)) out%dbvars = out%dbvars + 1 end do end if - if (schlieren_wrt) dbvars = dbvars + 1 + if (schlieren_wrt) out%dbvars = out%dbvars + 1 end if end subroutine s_initialize_data_output_module @@ -359,56 +319,56 @@ contains if (format == format_silo) then write (file_loc, '(A,I0,A)') '/', t_step, '.silo' - file_loc = trim(proc_rank_dir) // trim(file_loc) + file_loc = trim(out%proc_rank_dir) // trim(file_loc) - ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, dbfile) + ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, out%dbfile) - if (dbfile == -1) then + if (out%dbfile == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'slave file ' // trim(file_loc) // '. ' // 'Exiting.') end if if (proc_rank == 0) then write (file_loc, '(A,I0,A)') '/collection_', t_step, '.silo' - file_loc = trim(rootdir) // trim(file_loc) + file_loc = trim(out%rootdir) // trim(file_loc) - ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, dbroot) + ierr = DBCREATE(trim(file_loc), len_trim(file_loc), DB_CLOBBER, DB_LOCAL, 'MFC v3.0', 8, DB_HDF5, out%dbroot) - if (dbroot == -1) then + if (out%dbroot == -1) then call s_mpi_abort('Unable to create Silo-HDF5 database ' // 'master file ' // trim(file_loc) // '. ' & & // 'Exiting.') end if end if else write (file_loc, '(A,I0,A)') '/', t_step, '.dat' - file_loc = trim(proc_rank_dir) // trim(file_loc) + file_loc = trim(out%proc_rank_dir) // trim(file_loc) - open (dbfile, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') + open (out%dbfile, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') if (err /= 0) then call s_mpi_abort('Unable to create Binary database slave ' // 'file ' // trim(file_loc) // '. Exiting.') end if if (output_partial_domain) then - write (dbfile) x_output_idx%end - x_output_idx%beg, y_output_idx%end - y_output_idx%beg, & - & z_output_idx%end - z_output_idx%beg, dbvars + write (out%dbfile) x_output_idx%end - x_output_idx%beg, y_output_idx%end - y_output_idx%beg, & + & z_output_idx%end - z_output_idx%beg, out%dbvars else - write (dbfile) m, n, p, dbvars + write (out%dbfile) m, n, p, out%dbvars end if if (n == 0 .and. proc_rank == 0) then write (file_loc, '(A,I0,A)') '/', t_step, '.dat' - file_loc = trim(rootdir) // trim(file_loc) + file_loc = trim(out%rootdir) // trim(file_loc) - open (dbroot, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') + open (out%dbroot, IOSTAT=err, FILE=trim(file_loc), form='unformatted', STATUS='replace') if (err /= 0) then call s_mpi_abort('Unable to create Binary database ' // 'master file ' // trim(file_loc) // '. Exiting.') end if if (output_partial_domain) then - write (dbroot) x_output_idx%end - x_output_idx%beg, 0, 0, dbvars + write (out%dbroot) x_output_idx%end - x_output_idx%beg, 0, 0, out%dbvars else - write (dbroot) m_root, 0, 0, dbvars + write (out%dbroot) m_root, 0, 0, out%dbvars end if end if end if @@ -454,17 +414,19 @@ contains ! For multidimensional data sets, the spatial extents of all of the grid(s) handled by the local processor(s) are ! recorded so that they may be written, by root processor, to the formatted database master file. if (num_procs > 1) then - call s_mpi_gather_spatial_extents(spatial_extents) + call s_mpi_gather_spatial_extents(out%spatial_extents) else if (p > 0) then if (grid_geometry == 3) then - spatial_extents(:,0) = (/minval(y_cb), minval(z_cb), minval(x_cb), maxval(y_cb), maxval(z_cb), maxval(x_cb)/) + out%spatial_extents(:,0) = (/minval(y_cb), minval(z_cb), minval(x_cb), maxval(y_cb), maxval(z_cb), & + & maxval(x_cb)/) else - spatial_extents(:,0) = (/minval(x_cb), minval(y_cb), minval(z_cb), maxval(x_cb), maxval(y_cb), maxval(z_cb)/) + out%spatial_extents(:,0) = (/minval(x_cb), minval(y_cb), minval(z_cb), maxval(x_cb), maxval(y_cb), & + & maxval(z_cb)/) end if else if (n > 0) then - spatial_extents(:,0) = (/minval(x_cb), minval(y_cb), maxval(x_cb), maxval(y_cb)/) + out%spatial_extents(:,0) = (/minval(x_cb), minval(y_cb), maxval(x_cb), maxval(y_cb)/) else - spatial_extents(:,0) = (/minval(x_cb), maxval(x_cb)/) + out%spatial_extents(:,0) = (/minval(x_cb), maxval(x_cb)/) end if ! Next, the root processor proceeds to record all of the spatial extents in the formatted database master file. In @@ -478,66 +440,66 @@ contains meshtypes = DB_QUAD_RECT err = DBSET2DSTRLEN(len(meshnames(1))) - err = DBMKOPTLIST(2, optlist) - err = DBADDIOPT(optlist, DBOPT_EXTENTS_SIZE, size(spatial_extents, 1)) - err = DBADDDOPT(optlist, DBOPT_EXTENTS, spatial_extents) - err = DBPUTMMESH(dbroot, 'rectilinear_grid', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, optlist, & - & ierr) - err = DBFREEOPTLIST(optlist) + err = DBMKOPTLIST(2, out%optlist) + err = DBADDIOPT(out%optlist, DBOPT_EXTENTS_SIZE, size(out%spatial_extents, 1)) + err = DBADDDOPT(out%optlist, DBOPT_EXTENTS, out%spatial_extents) + err = DBPUTMMESH(out%dbroot, 'rectilinear_grid', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, & + & out%optlist, ierr) + err = DBFREEOPTLIST(out%optlist) end if ! Finally, the local quadrilateral mesh, either 2D or 3D, along with its offsets that indicate the presence and size of ! ghost zone layer(s), are put in the formatted database slave file. if (p > 0) then - err = DBMKOPTLIST(2, optlist) - err = DBADDIAOPT(optlist, DBOPT_LO_OFFSET, size(lo_offset), lo_offset) - err = DBADDIAOPT(optlist, DBOPT_HI_OFFSET, size(hi_offset), hi_offset) + err = DBMKOPTLIST(2, out%optlist) + err = DBADDIAOPT(out%optlist, DBOPT_LO_OFFSET, size(out%lo_offset), out%lo_offset) + err = DBADDIAOPT(out%optlist, DBOPT_HI_OFFSET, size(out%hi_offset), out%hi_offset) if (grid_geometry == 3) then - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, y_cb, z_cb, x_cb, dims, 3, DB_DOUBLE, & - & DB_COLLINEAR, optlist, ierr) + err = DBPUTQM(out%dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, y_cb, z_cb, x_cb, out%dims, 3, & + & DB_DOUBLE, DB_COLLINEAR, out%optlist, ierr) else - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, y_cb, z_cb, dims, 3, DB_DOUBLE, & - & DB_COLLINEAR, optlist, ierr) + err = DBPUTQM(out%dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, y_cb, z_cb, out%dims, 3, & + & DB_DOUBLE, DB_COLLINEAR, out%optlist, ierr) end if - err = DBFREEOPTLIST(optlist) + err = DBFREEOPTLIST(out%optlist) else if (n > 0) then - err = DBMKOPTLIST(2, optlist) - err = DBADDIAOPT(optlist, DBOPT_LO_OFFSET, size(lo_offset), lo_offset) - err = DBADDIAOPT(optlist, DBOPT_HI_OFFSET, size(hi_offset), hi_offset) - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, y_cb, DB_F77NULL, dims, 2, DB_DOUBLE, & - & DB_COLLINEAR, optlist, ierr) - err = DBFREEOPTLIST(optlist) + err = DBMKOPTLIST(2, out%optlist) + err = DBADDIAOPT(out%optlist, DBOPT_LO_OFFSET, size(out%lo_offset), out%lo_offset) + err = DBADDIAOPT(out%optlist, DBOPT_HI_OFFSET, size(out%hi_offset), out%hi_offset) + err = DBPUTQM(out%dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, y_cb, DB_F77NULL, out%dims, 2, & + & DB_DOUBLE, DB_COLLINEAR, out%optlist, ierr) + err = DBFREEOPTLIST(out%optlist) else - err = DBMKOPTLIST(2, optlist) - err = DBADDIAOPT(optlist, DBOPT_LO_OFFSET, size(lo_offset), lo_offset) - err = DBADDIAOPT(optlist, DBOPT_HI_OFFSET, size(hi_offset), hi_offset) - err = DBPUTQM(dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, DB_F77NULL, DB_F77NULL, dims, 1, & - & DB_DOUBLE, DB_COLLINEAR, optlist, ierr) - err = DBFREEOPTLIST(optlist) + err = DBMKOPTLIST(2, out%optlist) + err = DBADDIAOPT(out%optlist, DBOPT_LO_OFFSET, size(out%lo_offset), out%lo_offset) + err = DBADDIAOPT(out%optlist, DBOPT_HI_OFFSET, size(out%hi_offset), out%hi_offset) + err = DBPUTQM(out%dbfile, 'rectilinear_grid', 16, 'x', 1, 'y', 1, 'z', 1, x_cb, DB_F77NULL, DB_F77NULL, out%dims, & + & 1, DB_DOUBLE, DB_COLLINEAR, out%optlist, ierr) + err = DBFREEOPTLIST(out%optlist) end if else if (format == format_binary) then ! Multidimensional local grid data is written to the formatted database slave file. Recall that no master file to ! maintained in multidimensions. if (p > 0) then if (precision == precision_single) then - write (dbfile) real(x_cb, sp), real(y_cb, sp), real(z_cb, sp) + write (out%dbfile) real(x_cb, sp), real(y_cb, sp), real(z_cb, sp) else if (output_partial_domain) then - write (dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end), y_cb(y_output_idx%beg - 1:y_output_idx%end), & - & z_cb(z_output_idx%beg - 1:z_output_idx%end) + write (out%dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end), & + & y_cb(y_output_idx%beg - 1:y_output_idx%end), z_cb(z_output_idx%beg - 1:z_output_idx%end) else - write (dbfile) x_cb, y_cb, z_cb + write (out%dbfile) x_cb, y_cb, z_cb end if end if else if (n > 0) then if (precision == precision_single) then - write (dbfile) real(x_cb, sp), real(y_cb, sp) + write (out%dbfile) real(x_cb, sp), real(y_cb, sp) else if (output_partial_domain) then - write (dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end), y_cb(y_output_idx%beg - 1:y_output_idx%end) + write (out%dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end), y_cb(y_output_idx%beg - 1:y_output_idx%end) else - write (dbfile) x_cb, y_cb + write (out%dbfile) x_cb, y_cb end if end if @@ -545,12 +507,12 @@ contains ! is put together by the root process and written to the master file. else if (precision == precision_single) then - write (dbfile) real(x_cb, sp) + write (out%dbfile) real(x_cb, sp) else if (output_partial_domain) then - write (dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end) + write (out%dbfile) x_cb(x_output_idx%beg - 1:x_output_idx%end) else - write (dbfile) x_cb + write (out%dbfile) x_cb end if end if @@ -562,12 +524,12 @@ contains if (proc_rank == 0) then if (precision == precision_single) then - write (dbroot) real(x_root_cb, wp) + write (out%dbroot) real(x_root_cb, wp) else if (output_partial_domain) then - write (dbroot) x_root_cb(x_output_idx%beg - 1:x_output_idx%end) + write (out%dbroot) x_root_cb(x_output_idx%beg - 1:x_output_idx%end) else - write (dbroot) x_root_cb + write (out%dbroot) x_root_cb end if end if end if @@ -591,9 +553,9 @@ contains if (format == format_silo) then ! Determining the extents of the flow variable on each local process and gathering all this information on root process if (num_procs > 1) then - call s_mpi_gather_data_extents(q_sf, data_extents) + call s_mpi_gather_data_extents(out%q_sf, out%data_extents) else - data_extents(:,0) = (/minval(q_sf), maxval(q_sf)/) + out%data_extents(:,0) = (/minval(out%q_sf), maxval(out%q_sf)/) end if if (proc_rank == 0) then @@ -604,12 +566,12 @@ contains vartypes = DB_QUADVAR err = DBSET2DSTRLEN(len(varnames(1))) - err = DBMKOPTLIST(2, optlist) - err = DBADDIOPT(optlist, DBOPT_EXTENTS_SIZE, 2) - err = DBADDDOPT(optlist, DBOPT_EXTENTS, data_extents) - err = DBPUTMVAR(dbroot, trim(varname), len_trim(varname), num_procs, varnames, len_trim(varnames), vartypes, & - & optlist, ierr) - err = DBFREEOPTLIST(optlist) + err = DBMKOPTLIST(2, out%optlist) + err = DBADDIOPT(out%optlist, DBOPT_EXTENTS_SIZE, 2) + err = DBADDDOPT(out%optlist, DBOPT_EXTENTS, out%data_extents) + err = DBPUTMVAR(out%dbroot, trim(varname), len_trim(varname), num_procs, varnames, len_trim(varnames), vartypes, & + & out%optlist, ierr) + err = DBFREEOPTLIST(out%optlist) end if if (wp == dp) then @@ -617,7 +579,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - q_sf_s(i, j, k) = real(q_sf(i, j, k), sp) + out%q_sf_s(i, j, k) = real(out%q_sf(i, j, k), sp) end do end do end do @@ -625,7 +587,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - cyl_q_sf_s(j, k, i) = q_sf_s(i, j, k) + out%cyl_q_sf_s(j, k, i) = out%q_sf_s(i, j, k) end do end do end do @@ -635,7 +597,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - cyl_q_sf(j, k, i) = q_sf(i, j, k) + out%cyl_q_sf(j, k, i) = out%q_sf(i, j, k) end do end do end do @@ -645,7 +607,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - q_sf_s(i, j, k) = q_sf(i, j, k) + out%q_sf_s(i, j, k) = out%q_sf(i, j, k) end do end do end do @@ -653,7 +615,7 @@ contains do i = -offset_x%beg, m + offset_x%end do j = -offset_y%beg, n + offset_y%end do k = -offset_z%beg, p + offset_z%end - cyl_q_sf_s(j, k, i) = q_sf_s(i, j, k) + out%cyl_q_sf_s(j, k, i) = out%q_sf_s(i, j, k) end do end do end do @@ -664,18 +626,19 @@ contains if (precision == ${PRECISION}$) then if (p > 0) then if (grid_geometry == 3) then - err = DBPUTQV1(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, cyl_q_sf${SFX}$, & - & dims - 1, 3, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) + err = DBPUTQV1(out%dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, & + & out%cyl_q_sf${SFX}$, out%dims - 1, 3, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, & + & DB_F77NULL, ierr) else - err = DBPUTQV1(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, q_sf${SFX}$, & - & dims - 1, 3, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) + err = DBPUTQV1(out%dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, out%q_sf${SFX}$, & + & out%dims - 1, 3, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if else if (n > 0) then - err = DBPUTQV1(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, q_sf${SFX}$, dims - 1, & - & 2, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) + err = DBPUTQV1(out%dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, out%q_sf${SFX}$, & + & out%dims - 1, 2, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) else - err = DBPUTQV1(dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, q_sf${SFX}$, dims - 1, & - & 1, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) + err = DBPUTQV1(out%dbfile, trim(varname), len_trim(varname), 'rectilinear_grid', 16, out%q_sf${SFX}$, & + & out%dims - 1, 1, DB_F77NULL, 0, ${DBT}$, DB_ZONECENT, DB_F77NULL, ierr) end if end if #:endfor @@ -683,25 +646,25 @@ contains ! Writing the name of the flow variable and its data, associated with the local processor, to the formatted database ! slave file if (precision == precision_single) then - write (dbfile) varname, real(q_sf, wp) + write (out%dbfile) varname, real(out%q_sf, wp) else - write (dbfile) varname, q_sf + write (out%dbfile) varname, out%q_sf end if ! In 1D, the root process also takes care of gathering the flow variable data from all of the local processor(s) and ! writes it to the formatted database master file. if (n == 0) then if (num_procs > 1) then - call s_mpi_defragment_1d_flow_variable(q_sf, q_root_sf) + call s_mpi_defragment_1d_flow_variable(out%q_sf, out%q_root_sf) else - q_root_sf(:,:,:) = q_sf(:,:,:) + out%q_root_sf(:,:,:) = out%q_sf(:,:,:) end if if (proc_rank == 0) then if (precision == precision_single) then - write (dbroot) varname, real(q_root_sf, wp) + write (out%dbroot) varname, real(out%q_root_sf, wp) else - write (dbroot) varname, q_root_sf + write (out%dbroot) varname, out%q_root_sf end if end if end if @@ -993,10 +956,11 @@ contains meshtypes(i) = DB_POINTMESH end do err = DBSET2DSTRLEN(len(meshnames(1))) - err = DBPUTMMESH(dbroot, 'lag_bubbles', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, ierr) + err = DBPUTMMESH(out%dbroot, 'lag_bubbles', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, & + & ierr) end if - err = DBPUTPM(dbfile, 'lag_bubbles', 11, 3, px, py, pz, nBub, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPM(out%dbfile, 'lag_bubbles', 11, 3, px, py, pz, nBub, DB_DOUBLE, DB_F77NULL, ierr) if (lag_id_wrt) call s_write_lag_variable_to_formatted_database_file('part_id', t_step, bub_id, nBub) if (lag_vel_wrt) then @@ -1041,11 +1005,12 @@ contains meshtypes(i) = DB_POINTMESH end do err = DBSET2DSTRLEN(len(meshnames(1))) - err = DBPUTMMESH(dbroot, 'lag_bubbles', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, ierr) + err = DBPUTMMESH(out%dbroot, 'lag_bubbles', 16, num_procs, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, & + & ierr) end if err = DBSETEMPTYOK(1) - err = DBPUTPM(dbfile, 'lag_bubbles', 11, 3, dummy_data, dummy_data, dummy_data, 0, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPM(out%dbfile, 'lag_bubbles', 11, 3, dummy_data, dummy_data, dummy_data, 0, DB_DOUBLE, DB_F77NULL, ierr) if (lag_id_wrt) call s_write_lag_variable_to_formatted_database_file('part_id', t_step) if (lag_vel_wrt) then @@ -1091,11 +1056,12 @@ contains var_types(i) = DB_POINTVAR end do err = DBSET2DSTRLEN(len(var_names(1))) - err = DBPUTMVAR(dbroot, trim(varname), len_trim(varname), num_procs, var_names, len_trim(var_names), var_types, & - & DB_F77NULL, ierr) + err = DBPUTMVAR(out%dbroot, trim(varname), len_trim(varname), num_procs, var_names, len_trim(var_names), & + & var_types, DB_F77NULL, ierr) end if - err = DBPUTPV1(dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, data, nBubs, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPV1(out%dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, data, nBubs, DB_DOUBLE, DB_F77NULL, & + & ierr) else if (proc_rank == 0) then do i = 1, num_procs @@ -1104,12 +1070,13 @@ contains end do err = DBSET2DSTRLEN(len(var_names(1))) err = DBSETEMPTYOK(1) - err = DBPUTMVAR(dbroot, trim(varname), len_trim(varname), num_procs, var_names, len_trim(var_names), var_types, & - & DB_F77NULL, ierr) + err = DBPUTMVAR(out%dbroot, trim(varname), len_trim(varname), num_procs, var_names, len_trim(var_names), & + & var_types, DB_F77NULL, ierr) end if err = DBSETEMPTYOK(1) - err = DBPUTPV1(dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, dummy_data, 0, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPV1(out%dbfile, trim(varname), len_trim(varname), 'lag_bubbles', 11, dummy_data, 0, DB_DOUBLE, DB_F77NULL, & + & ierr) end if end subroutine s_write_lag_variable_to_formatted_database_file @@ -1440,9 +1407,9 @@ contains write (meshnames(1), '(A,I0,A)') '../p0/', t_step, '.silo:ib_bodies' meshtypes(1) = DB_POINTMESH err = DBSET2DSTRLEN(len(meshnames(1))) - err = DBPUTMMESH(dbroot, 'ib_bodies', 16, 1, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, ierr) + err = DBPUTMMESH(out%dbroot, 'ib_bodies', 16, 1, meshnames, len_trim(meshnames), meshtypes, DB_F77NULL, ierr) - err = DBPUTPM(dbfile, 'ib_bodies', 9, 3, px, py, pz, nBodies, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPM(out%dbfile, 'ib_bodies', 9, 3, px, py, pz, nBodies, DB_DOUBLE, DB_F77NULL, ierr) call s_write_ib_variable('ib_force_x', t_step, force_x, nBodies) call s_write_ib_variable('ib_force_y', t_step, force_y, nBodies) @@ -1484,10 +1451,10 @@ contains write (var_name_entry, '(A,I0,A)') '../p0/', t_step, '.silo:' // trim(varname) var_type_entry = DB_POINTVAR err = DBSET2DSTRLEN(len(var_name_entry)) - err = DBPUTMVAR(dbroot, trim(varname), len_trim(varname), 1, var_name_entry, len_trim(var_name_entry), var_type_entry, & - & DB_F77NULL, ierr) + err = DBPUTMVAR(out%dbroot, trim(varname), len_trim(varname), 1, var_name_entry, len_trim(var_name_entry), & + & var_type_entry, DB_F77NULL, ierr) - err = DBPUTPV1(dbfile, trim(varname), len_trim(varname), 'ib_bodies', 9, data, nBodies, DB_DOUBLE, DB_F77NULL, ierr) + err = DBPUTPV1(out%dbfile, trim(varname), len_trim(varname), 'ib_bodies', 9, data, nBodies, DB_DOUBLE, DB_F77NULL, ierr) end subroutine s_write_ib_variable @@ -1497,11 +1464,11 @@ contains integer :: ierr if (format == format_silo) then - ierr = DBCLOSE(dbfile) - if (proc_rank == 0) ierr = DBCLOSE(dbroot) + ierr = DBCLOSE(out%dbfile) + if (proc_rank == 0) ierr = DBCLOSE(out%dbroot) else - close (dbfile) - if (n == 0 .and. proc_rank == 0) close (dbroot) + close (out%dbfile) + if (n == 0 .and. proc_rank == 0) close (out%dbroot) end if end subroutine s_close_formatted_database_file @@ -1523,21 +1490,21 @@ contains !> Deallocate module arrays and release all data-output resources. impure subroutine s_finalize_data_output_module() - deallocate (q_sf) - if (n == 0) deallocate (q_root_sf) + deallocate (out%q_sf) + if (n == 0) deallocate (out%q_root_sf) if (grid_geometry == 3) then - deallocate (cyl_q_sf) + deallocate (out%cyl_q_sf) end if ! Deallocating spatial and data extents and also the variables for the offsets and the one bookkeeping the number of ! cell-boundaries in each active coordinate direction. Note that all these variables were only needed by Silo-HDF5 format ! for multidimensional data. if (format == format_silo) then - deallocate (spatial_extents) - deallocate (data_extents) - deallocate (lo_offset) - deallocate (hi_offset) - deallocate (dims) + deallocate (out%spatial_extents) + deallocate (out%data_extents) + deallocate (out%lo_offset) + deallocate (out%hi_offset) + deallocate (out%dims) end if end subroutine s_finalize_data_output_module diff --git a/src/post_process/m_start_up.fpp b/src/post_process/m_start_up.fpp index a917d25239..7284190160 100644 --- a/src/post_process/m_start_up.fpp +++ b/src/post_process/m_start_up.fpp @@ -228,7 +228,7 @@ contains if ((model_eqns == model_eqns_5eq) .or. (model_eqns == model_eqns_6eq) .or. (model_eqns == model_eqns_4eq)) then do i = 1, num_fluids if (alpha_rho_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then - q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) if (model_eqns /= model_eqns_4eq) then write (varname, '(A,I0)') 'alpha_rho', i else @@ -243,7 +243,7 @@ contains if ((rho_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) .and. (.not. relativity)) & & then - q_sf(:,:,:) = rho_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = rho_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'rho' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -251,7 +251,7 @@ contains end if if (relativity .and. (rho_wrt .or. prim_vars_wrt)) then - q_sf(:,:,:) = q_prim_vf(1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'rho' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -260,7 +260,7 @@ contains if (relativity .and. (rho_wrt .or. cons_vars_wrt)) then ! For relativistic flow, conservative and primitive densities are different Hard-coded single-component for now - q_sf(:,:,:) = q_cons_vf(1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'D' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -269,7 +269,7 @@ contains do i = 1, eqn_idx%E - eqn_idx%mom%beg if (mom_wrt(i) .or. cons_vars_wrt) then - q_sf(:,:,:) = q_cons_vf(i + eqn_idx%cont%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(i + eqn_idx%cont%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'mom', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -279,7 +279,7 @@ contains do i = 1, eqn_idx%E - eqn_idx%mom%beg if (vel_wrt(i) .or. prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i + eqn_idx%cont%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(i + eqn_idx%cont%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'vel', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -290,7 +290,7 @@ contains if (chemistry) then do i = 1, num_species if (chem_wrt_Y(i) .or. prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(eqn_idx%species%beg + i - 1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(eqn_idx%species%beg + i - 1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,A)') 'Y_', trim(species_names(i)) call s_write_variable_to_formatted_database_file(varname, t_step) @@ -299,7 +299,7 @@ contains end do if (chem_wrt_T) then - q_sf(:,:,:) = q_T_sf%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_T_sf%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'T' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -309,7 +309,7 @@ contains do i = 1, eqn_idx%E - eqn_idx%mom%beg if (flux_wrt(i)) then - call s_derive_flux_limiter(i, q_prim_vf, q_sf) + call s_derive_flux_limiter(i, q_prim_vf, out%q_sf) write (varname, '(A,I0)') 'flux', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -319,7 +319,7 @@ contains end do if (E_wrt .or. cons_vars_wrt) then - q_sf(:,:,:) = q_cons_vf(eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'E' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -329,7 +329,7 @@ contains if (model_eqns == model_eqns_6eq) then do i = 1, num_fluids if (alpha_rho_e_wrt(i) .or. cons_vars_wrt) then - q_sf = q_cons_vf(i + eqn_idx%int_en%beg - 1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf = q_cons_vf(i + eqn_idx%int_en%beg - 1)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'alpha_rho_e', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -446,7 +446,7 @@ contains if (mhd .and. prim_vars_wrt) then do i = eqn_idx%B%beg, eqn_idx%B%end - q_sf(:,:,:) = q_prim_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) ! 1D: output By, Bz if (n == 0) then @@ -474,7 +474,7 @@ contains if (elasticity) then do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 if (prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i - 1 + eqn_idx%stress%beg)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(i - 1 + eqn_idx%stress%beg)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'tau', i call s_write_variable_to_formatted_database_file(varname, t_step) end if @@ -485,7 +485,7 @@ contains if (hyperelasticity) then do i = 1, eqn_idx%xi%end - eqn_idx%xi%beg + 1 if (prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(i - 1 + eqn_idx%xi%beg)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(i - 1 + eqn_idx%xi%beg)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'xi', i call s_write_variable_to_formatted_database_file(varname, t_step) end if @@ -494,7 +494,7 @@ contains end if if (cont_damage) then - q_sf(:,:,:) = q_cons_vf(eqn_idx%damage)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(eqn_idx%damage)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'damage_state' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -502,7 +502,7 @@ contains end if if (hyper_cleaning) then - q_sf = q_cons_vf(eqn_idx%psi)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf = q_cons_vf(eqn_idx%psi)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'psi' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -510,7 +510,7 @@ contains end if if (pres_wrt .or. prim_vars_wrt) then - q_sf(:,:,:) = q_prim_vf(eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_prim_vf(eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'pres' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -520,7 +520,7 @@ contains if (((model_eqns == model_eqns_5eq) .and. (bubbles_euler .neqv. .true.)) .or. (model_eqns == model_eqns_6eq)) then do i = 1, num_fluids - 1 if (alpha_wrt(i) .or. (cons_vars_wrt .or. prim_vars_wrt)) then - q_sf(:,:,:) = q_cons_vf(i + eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(i + eqn_idx%E)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'alpha', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -533,15 +533,15 @@ contains do k = z_beg, z_end do j = y_beg, y_end do i = x_beg, x_end - q_sf(i, j, k) = 1._wp + out%q_sf(i, j, k) = 1._wp do l = 1, num_fluids - 1 - q_sf(i, j, k) = q_sf(i, j, k) - q_cons_vf(eqn_idx%E + l)%sf(i, j, k) + out%q_sf(i, j, k) = out%q_sf(i, j, k) - q_cons_vf(eqn_idx%E + l)%sf(i, j, k) end do end do end do end do else - q_sf(:,:,:) = q_cons_vf(eqn_idx%adv%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(eqn_idx%adv%end)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) end if write (varname, '(A,I0)') 'alpha', num_fluids call s_write_variable_to_formatted_database_file(varname, t_step) @@ -551,7 +551,7 @@ contains end if if (gamma_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) then - q_sf(:,:,:) = gamma_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = gamma_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'gamma' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -559,7 +559,7 @@ contains end if if (heat_ratio_wrt) then - call s_derive_specific_heat_ratio(q_sf) + call s_derive_specific_heat_ratio(out%q_sf) write (varname, '(A)') 'heat_ratio' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -568,7 +568,7 @@ contains end if if (pi_inf_wrt .or. (model_eqns == model_eqns_gamma_law .and. (cons_vars_wrt .or. prim_vars_wrt))) then - q_sf(:,:,:) = pi_inf_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = pi_inf_sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'pi_inf' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -576,7 +576,7 @@ contains end if if (pres_inf_wrt) then - call s_derive_liquid_stiffness(q_sf) + call s_derive_liquid_stiffness(out%q_sf) write (varname, '(A)') 'pres_inf' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -599,7 +599,7 @@ contains call s_compute_speed_of_sound(pres, rho_sf(i, j, k), gamma_sf(i, j, k), pi_inf_sf(i, j, k), H, adv, & & 0._wp, 0._wp, c, qv_sf(i, j, k)) - q_sf(i, j, k) = c + out%q_sf(i, j, k) = c end do end do end do @@ -612,7 +612,7 @@ contains do i = 1, 3 if (omega_wrt(i)) then - call s_derive_vorticity_component(i, q_prim_vf, q_sf) + call s_derive_vorticity_component(i, q_prim_vf, out%q_sf) write (varname, '(A,I0)') 'omega', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -622,14 +622,14 @@ contains end do if (ib) then - q_sf(:,:,:) = real(ib_markers%sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end, & - & -offset_z%beg:p + offset_z%end)) + out%q_sf(:,:,:) = real(ib_markers%sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end, & + & -offset_z%beg:p + offset_z%end)) varname = 'ib_markers' call s_write_variable_to_formatted_database_file(varname, t_step) end if if (p > 0 .and. qm_wrt) then - call s_derive_qm(q_prim_vf, q_sf) + call s_derive_qm(q_prim_vf, out%q_sf) write (varname, '(A)') 'qm' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -640,7 +640,7 @@ contains if (liutex_wrt) then call s_derive_liutex(q_prim_vf, liutex_mag, liutex_axis) - q_sf = liutex_mag + out%q_sf = liutex_mag write (varname, '(A)') 'liutex_mag' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -648,7 +648,7 @@ contains varname(:) = ' ' do i = 1, 3 - q_sf = liutex_axis(:,:,:,i) + out%q_sf = liutex_axis(:,:,:,i) write (varname, '(A,I0)') 'liutex_axis', i call s_write_variable_to_formatted_database_file(varname, t_step) @@ -658,7 +658,7 @@ contains end if if (schlieren_wrt) then - call s_derive_numerical_schlieren_function(q_cons_vf, q_sf) + call s_derive_numerical_schlieren_function(q_cons_vf, out%q_sf) write (varname, '(A)') 'schlieren' call s_write_variable_to_formatted_database_file(varname, t_step) @@ -667,7 +667,7 @@ contains end if if (cf_wrt) then - q_sf(:,:,:) = q_cons_vf(eqn_idx%c)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(eqn_idx%c)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'color_function' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -675,7 +675,7 @@ contains if (bubbles_euler) then do i = eqn_idx%adv%beg, eqn_idx%adv%end - q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(i)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I0)') 'alpha', i - eqn_idx%E call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -685,7 +685,7 @@ contains if (bubbles_euler) then ! nR do i = 1, nb - q_sf(:,:,:) = q_cons_vf(qbmm_idx%rs(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(qbmm_idx%rs(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I3.3)') 'nR', i call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -693,7 +693,7 @@ contains ! nRdot do i = 1, nb - q_sf(:,:,:) = q_cons_vf(qbmm_idx%vs(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(qbmm_idx%vs(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I3.3)') 'nV', i call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -701,7 +701,7 @@ contains if ((polytropic .neqv. .true.) .and. (.not. qbmm)) then ! nP do i = 1, nb - q_sf(:,:,:) = q_cons_vf(qbmm_idx%ps(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(qbmm_idx%ps(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I3.3)') 'nP', i call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -709,7 +709,7 @@ contains ! nM do i = 1, nb - q_sf(:,:,:) = q_cons_vf(qbmm_idx%ms(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(qbmm_idx%ms(i))%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A,I3.3)') 'nM', i call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -718,7 +718,7 @@ contains ! number density if (adv_n) then - q_sf(:,:,:) = q_cons_vf(eqn_idx%n)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) + out%q_sf(:,:,:) = q_cons_vf(eqn_idx%n)%sf(x_beg:x_end,y_beg:y_end,z_beg:z_end) write (varname, '(A)') 'n' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' @@ -727,8 +727,8 @@ contains if (bubbles_lagrange) then ! Void fraction field - q_sf(:,:,:) = 1._wp - q_cons_vf(beta_idx)%sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end, & - & -offset_z%beg:p + offset_z%end) + out%q_sf(:,:,:) = 1._wp - q_cons_vf(beta_idx)%sf(-offset_x%beg:m + offset_x%end,-offset_y%beg:n + offset_y%end, & + & -offset_z%beg:p + offset_z%end) write (varname, '(A)') 'voidFraction' call s_write_variable_to_formatted_database_file(varname, t_step) varname(:) = ' ' From b8969f9b69343185aca3f5e6407cc9a027371b20 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 00:20:43 -0400 Subject: [PATCH 03/11] cleanup: registry-driven recon_type validation, deterministic fypp loops, stale import --- src/post_process/m_global_parameters.fpp | 2 +- src/pre_process/m_boundary_conditions.fpp | 1 - src/pre_process/m_global_parameters.fpp | 2 +- src/simulation/m_cbc.fpp | 2 +- src/simulation/m_global_parameters.fpp | 8 ++++---- src/simulation/m_start_up.fpp | 2 +- toolchain/mfc/case_validator.py | 9 ++++++++- 7 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/post_process/m_global_parameters.fpp b/src/post_process/m_global_parameters.fpp index 9d52c67e35..9ee0c2ed02 100644 --- a/src/post_process/m_global_parameters.fpp +++ b/src/post_process/m_global_parameters.fpp @@ -163,7 +163,7 @@ contains #:endfor #:endfor - #:for dir in {'x', 'y', 'z'} + #:for dir in ['x', 'y', 'z'] bc_${dir}$%isothermal_in = .false. bc_${dir}$%isothermal_out = .false. bc_${dir}$%Twall_in = dflt_real diff --git a/src/pre_process/m_boundary_conditions.fpp b/src/pre_process/m_boundary_conditions.fpp index 70c3485a12..119108fe0b 100644 --- a/src/pre_process/m_boundary_conditions.fpp +++ b/src/pre_process/m_boundary_conditions.fpp @@ -12,7 +12,6 @@ module m_boundary_conditions #endif use m_delay_file_access use m_compile_specific - use m_boundary_common implicit none diff --git a/src/pre_process/m_global_parameters.fpp b/src/pre_process/m_global_parameters.fpp index bfb5df737d..1c95a23d02 100644 --- a/src/pre_process/m_global_parameters.fpp +++ b/src/pre_process/m_global_parameters.fpp @@ -112,7 +112,7 @@ contains #:endfor #:endfor - #:for dir in {'x', 'y', 'z'} + #:for dir in ['x', 'y', 'z'] bc_${dir}$%isothermal_in = .false. bc_${dir}$%isothermal_out = .false. bc_${dir}$%Twall_in = dflt_real diff --git a/src/simulation/m_cbc.fpp b/src/simulation/m_cbc.fpp index d534169504..839485464c 100644 --- a/src/simulation/m_cbc.fpp +++ b/src/simulation/m_cbc.fpp @@ -1349,7 +1349,7 @@ contains toggle = .false. - #:for BC in {-5, -6, -7, -8, -9, -10, -11, -12, -13} + #:for BC in [-5, -6, -7, -8, -9, -10, -11, -12, -13] if (any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, bc_z%end/) == ${BC}$)) then toggle = .true. end if diff --git a/src/simulation/m_global_parameters.fpp b/src/simulation/m_global_parameters.fpp index 7a22a67afb..8d8cebda28 100644 --- a/src/simulation/m_global_parameters.fpp +++ b/src/simulation/m_global_parameters.fpp @@ -293,7 +293,7 @@ contains #:endfor #:endfor - #:for dir in {'x', 'y', 'z'} + #:for dir in ['x', 'y', 'z'] bc_${dir}$%isothermal_in = .false. bc_${dir}$%isothermal_out = .false. bc_${dir}$%Twall_in = dflt_real @@ -456,8 +456,8 @@ contains bodyForces = .false. bf_x = .false.; bf_y = .false.; bf_z = .false. !> amplitude, frequency, and phase shift sinusoid in each direction - #:for dir in {'x', 'y', 'z'} - #:for param in {'k','w','p','g'} + #:for dir in ['x', 'y', 'z'] + #:for param in ['k', 'w', 'p', 'g'] ${param}$_${dir}$ = dflt_real #:endfor #:endfor @@ -513,7 +513,7 @@ contains end do ! GRCBC flags - #:for dir in {'x', 'y', 'z'} + #:for dir in ['x', 'y', 'z'] bc_${dir}$%grcbc_in = .false. bc_${dir}$%grcbc_out = .false. bc_${dir}$%grcbc_vel_out = .false. diff --git a/src/simulation/m_start_up.fpp b/src/simulation/m_start_up.fpp index e0976f9270..4651133b83 100644 --- a/src/simulation/m_start_up.fpp +++ b/src/simulation/m_start_up.fpp @@ -800,7 +800,7 @@ contains call s_initialize_global_parameters_module() #:if USING_AMD - #:for BC in {-5, -6, -7, -8, -9, -10, -11, -12, -13} + #:for BC in [-5, -6, -7, -8, -9, -10, -11, -12, -13] @:PROHIBIT(any((/bc_x%beg, bc_x%end, bc_y%beg, bc_y%end, bc_z%beg, & & bc_z%end/) == ${BC}$) .and. eqn_idx%adv%end > 20 .and. (.not. chemistry), & & "CBC module with AMD compiler requires eqn_idx%adv%end <= 20 when case optimization is turned off") diff --git a/toolchain/mfc/case_validator.py b/toolchain/mfc/case_validator.py index bbb777589e..4039cc94ad 100644 --- a/toolchain/mfc/case_validator.py +++ b/toolchain/mfc/case_validator.py @@ -294,7 +294,14 @@ def check_parameter_types(self): if param in self.params: # Only validate params that are set self._validate_logical(param) - self.prohibit(self.get("recon_type", 1) not in [1, 2], "recon_type must be 1 (WENO) or 2 (MUSCL)") + _recon_constraint = CONSTRAINTS["recon_type"] + _recon_choices = _recon_constraint["choices"] + _recon_by_value = {v: n for n, v in _recon_constraint.get("names", {}).items()} + _recon_shown = ", ".join(f"{c} ({_recon_by_value[c]})" if c in _recon_by_value else str(c) for c in _recon_choices) + self.prohibit( + self.get("recon_type", 1) not in _recon_choices, + f"recon_type must be one of {_recon_shown}", + ) # Required domain parameters when m > 0 m = self.get("m") From a8ea2e4723d68092c9dc0bca5e91d7bb127d3018 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:00:18 -0400 Subject: [PATCH 04/11] src: allocate finite-difference coefficients when only qm_wrt is set The allocation guards in s_initialize_derived_variables_module omitted qm_wrt while the s_compute_finite_difference_coefficients call guards in m_start_up include it, so a case writing only the Q-criterion accessed unallocated arrays. Pre-existing; found during fd_context review. Guards now mirror the call sites exactly. --- src/post_process/m_derived_variables.fpp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/post_process/m_derived_variables.fpp b/src/post_process/m_derived_variables.fpp index 3da2dc13ed..05f1fc1805 100644 --- a/src/post_process/m_derived_variables.fpp +++ b/src/post_process/m_derived_variables.fpp @@ -34,15 +34,15 @@ contains ! Allocate FD coefficients (up to 4th order; higher orders need extension) - if (omega_wrt(2) .or. omega_wrt(3) .or. schlieren_wrt .or. liutex_wrt) then + if (omega_wrt(2) .or. omega_wrt(3) .or. qm_wrt .or. schlieren_wrt .or. liutex_wrt) then allocate (fd%fd_coeff_x(-fd_number:fd_number,-offset_x%beg:m + offset_x%end)) end if - if (omega_wrt(1) .or. omega_wrt(3) .or. liutex_wrt .or. (n > 0 .and. schlieren_wrt)) then + if (omega_wrt(1) .or. omega_wrt(3) .or. qm_wrt .or. liutex_wrt .or. (n > 0 .and. schlieren_wrt)) then allocate (fd%fd_coeff_y(-fd_number:fd_number,-offset_y%beg:n + offset_y%end)) end if - if (omega_wrt(1) .or. omega_wrt(2) .or. liutex_wrt .or. (p > 0 .and. schlieren_wrt)) then + if (omega_wrt(1) .or. omega_wrt(2) .or. qm_wrt .or. liutex_wrt .or. (p > 0 .and. schlieren_wrt)) then allocate (fd%fd_coeff_z(-fd_number:fd_number,-offset_z%beg:p + offset_z%end)) end if From 94a87f866713dedf05060359ed2c2602cccba47a Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:12:32 -0400 Subject: [PATCH 05/11] src: extract shared Riemann state and per-sweep helpers into m_riemann_state NFC, pure motion. The four solver bodies call s_initialize/finalize_riemann_solver, s_populate_riemann_states_variables_buffers, and s_compute_viscous_source_flux, so keeping those in the dispatching core would create a use-cycle once the solvers move out. They go to the new lowest layer together with the 14 GPU_DECLARE'd state items they consume (declares move with declarations; lowest-consumer rule, bc_buffers precedent). Module-level allocation, GPU updates, and deallocation stay in core's s_initialize/finalize_riemann_solvers_module via use-association. Statement-multiset union vs the parent differs only by module boilerplate; GPU-directive census md5 unchanged; declare-target scoping verified for both files. --- docs/module_categories.json | 1 + src/simulation/m_riemann_solvers.fpp | 1148 +------------------------ src/simulation/m_riemann_state.fpp | 1167 ++++++++++++++++++++++++++ 3 files changed, 1169 insertions(+), 1147 deletions(-) create mode 100644 src/simulation/m_riemann_state.fpp diff --git a/docs/module_categories.json b/docs/module_categories.json index 6734de2c53..3bef694fef 100644 --- a/docs/module_categories.json +++ b/docs/module_categories.json @@ -6,6 +6,7 @@ "m_time_steppers", "m_weno", "m_riemann_solvers", + "m_riemann_state", "m_muscl", "m_variables_conversion", "m_thinc" diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index f3dc56b7ec..4fecec51d3 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -21,7 +21,7 @@ module m_riemann_solvers use m_bubbles_EE use m_surface_tension use m_helper_basic - use m_hb_function + use m_riemann_state use m_chemistry use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & & get_mixture_energy_mass, get_species_specific_heats_r, get_species_enthalpies_rt, get_mixture_specific_heat_cp_mass @@ -31,46 +31,6 @@ module m_riemann_solvers private; public :: s_initialize_riemann_solvers_module, s_riemann_solver, s_hll_riemann_solver, s_hllc_riemann_solver, & & s_hlld_riemann_solver, s_lf_riemann_solver, s_finalize_riemann_solvers_module - !> The cell-boundary values of the fluxes (src - source) that are computed through the chosen Riemann problem solver, and the - !! direct evaluation of source terms, by using the left and right states given in qK_prim_rs_vf, dqK_prim_ds_vf where ds = dx, - !! dy or dz. - !> @{ - real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf, flux_src_rsx_vf - $:GPU_DECLARE(create='[flux_rsx_vf, flux_src_rsx_vf]') - !> @} - - !> The cell-boundary values of the geometrical source flux that are computed through the chosen Riemann problem solver by using - !! the left and right states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. - !> @{ - real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf - $:GPU_DECLARE(create='[flux_gsrc_rsx_vf]') - !> @} - - ! Cell-boundary velocity from Riemann solution; used for source flux - - real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf - $:GPU_DECLARE(create='[vel_src_rsx_vf]') - - real(wp), allocatable, dimension(:,:,:,:) :: mom_sp_rsx_vf - $:GPU_DECLARE(create='[mom_sp_rsx_vf]') - - real(wp), allocatable, dimension(:,:,:,:) :: Re_avg_rsx_vf - $:GPU_DECLARE(create='[Re_avg_rsx_vf]') - - !> @name Indical bounds in the s1-, s2- and s3-directions - !> @{ - type(int_bounds_info) :: is1, is2, is3 - type(int_bounds_info) :: isx, isy, isz - !> @} - - $:GPU_DECLARE(create='[is1, is2, is3, isx, isy, isz]') - - real(wp), allocatable, dimension(:) :: Gs_rs - $:GPU_DECLARE(create='[Gs_rs]') - - real(wp), allocatable, dimension(:,:) :: Res_gs - $:GPU_DECLARE(create='[Res_gs]') - contains !> Dispatch to the subroutines that are utilized to compute the Riemann problem solution. For additional information please @@ -100,31 +60,6 @@ contains end subroutine s_riemann_solver - !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical - !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) - !! s_compute_cylindrical_viscous_source_flux - subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & - - & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & - & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf - - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - if (grid_geometry == 3) then - call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & - & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir, ix, iy, iz) - else - call s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, dvelR_dx_vf, dvelR_dy_vf, & - & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir) - end if - - end subroutine s_compute_viscous_source_flux - !> HLL approximate Riemann solver, Harten et al. SIAM Review (1983) subroutine s_hll_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & @@ -3606,1087 +3541,6 @@ contains end subroutine s_initialize_riemann_solvers_module - !> Populate the left and right Riemann state variable buffers based on boundary conditions - subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, & - - & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_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 - - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - integer :: i, j, k, l !< Generic loop iterator - - if (norm_dir == 1) then - is1 = ix; is2 = iy; is3 = iz - dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) - else if (norm_dir == 2) then - is1 = iy; is2 = ix; is3 = iz - dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) - else - is1 = iz; is2 = iy; is3 = ix - dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) - end if - - $:GPU_UPDATE(device='[is1, is2, is3]') - - if (elasticity) then - if (norm_dir == 1) then - dir_idx_tau = (/1, 2, 4/) - else if (norm_dir == 2) then - dir_idx_tau = (/3, 2, 5/) - else - dir_idx_tau = (/6, 4, 5/) - end if - end if - - isx = ix; isy = iy; isz = iz - ! for stuff in the same module - $:GPU_UPDATE(device='[isx, isy, isz]') - ! for stuff in different modules - $:GPU_UPDATE(device='[dir_idx, dir_flg, dir_idx_tau]') - - ! Population of Buffers in x-direction - if (norm_dir == 1) then - if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(-1, k, l, i) = qR_prim_rsx_vf(0, k, l, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (n > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (p > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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_GPU_PARALLEL_LOOP() - end if - end if - end if - end if - - if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(m + 1, k, l, i) = qL_prim_rsx_vf(m, k, l, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (n > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (p > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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_GPU_PARALLEL_LOOP() - end if - end if - end if - end if - ! END: Population of Buffers in x-direction - - ! Population of Buffers in y-direction - else if (norm_dir == 2) then - if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qL_prim_rsx_vf(k, -1, l, i) = qR_prim_rsx_vf(k, 0, l, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (p > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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_GPU_PARALLEL_LOOP() - end if - end if - end if - - if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - qR_prim_rsx_vf(k, n + 1, l, i) = qL_prim_rsx_vf(k, n, l, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - if (p > 0) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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_GPU_PARALLEL_LOOP() - end if - end if - end if - ! END: Population of Buffers in y-direction - - ! Population of Buffers in z-direction - else - if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do k = is2%beg, is2%end - do l = is3%beg, is3%end - qL_prim_rsx_vf(l, k, -1, i) = qR_prim_rsx_vf(l, k, 0, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - do k = isy%beg, isy%end - do j = isx%beg, isx%end - dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - end if - - if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = 1, sys_size - do k = is2%beg, is2%end - do l = is3%beg, is3%end - qR_prim_rsx_vf(l, k, p + 1, i) = qL_prim_rsx_vf(l, k, p, i) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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 - $:END_GPU_PARALLEL_LOOP() - - $:GPU_PARALLEL_LOOP(collapse=3) - do i = eqn_idx%mom%beg, eqn_idx%mom%end - 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_GPU_PARALLEL_LOOP() - end if - end if - end if - ! END: Population of Buffers in z-direction - - end subroutine s_populate_riemann_states_variables_buffers - - !> Set up the chosen Riemann solver algorithm for the current direction - subroutine s_initialize_riemann_solver(flux_src_vf, norm_dir) - - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - integer, intent(in) :: norm_dir - integer :: i, j, k, l !< Generic loop iterators - - ! Reshaping Inputted Data in x-direction - - if (norm_dir == 1) then - if (viscous .or. (surface_tension)) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%mom%beg, eqn_idx%E - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(i)%sf(j, k, l) = 0._wp - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%E, eqn_idx%species%end - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then - flux_src_vf(i)%sf(j, k, l) = 0._wp - end if - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (qbmm) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = 1, 4 - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end + 1 - mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - ! Reshaping Inputted Data in y-direction - else if (norm_dir == 2) then - if (viscous .or. (surface_tension)) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%mom%beg, eqn_idx%E - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(i)%sf(k, j, l) = 0._wp - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%E, eqn_idx%species%end - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then - flux_src_vf(i)%sf(k, j, l) = 0._wp - end if - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (qbmm) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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(k, j, l, i) = mom_sp(i)%sf(k, j, l) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - ! Reshaping Inputted Data in z-direction - else - if (viscous .or. (surface_tension)) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%mom%beg, eqn_idx%E - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(i)%sf(l, k, j) = 0._wp - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (chem_params%diffusion) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%E, eqn_idx%species%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then - flux_src_vf(i)%sf(l, k, j) = 0._wp - end if - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - if (qbmm) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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(l, k, j, i) = mom_sp(i)%sf(l, k, j) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - end if - - end subroutine s_initialize_riemann_solver - - !> Compute cylindrical viscous source flux contributions for momentum and energy - 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, q_prim_vf, norm_dir, ix, iy, iz) - - type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: avg_v_int !< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). - real(wp), dimension(3) :: avg_dvdx_int !< Averaged interface \f$\partial v_i/\partial x\f$ (grid dir 1). - real(wp), dimension(3) :: avg_dvdy_int !< Averaged interface \f$\partial v_i/\partial y\f$ (grid dir 2). - real(wp), dimension(3) :: avg_dvdz_int !< Averaged interface \f$\partial v_i/\partial z\f$ (grid dir 3). - real(wp), dimension(3) :: vel_src_int !< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. - - !> Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). - real(wp), dimension(3) :: stress_vector_shear - #:else - real(wp), dimension(num_dims) :: avg_v_int !< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). - real(wp), dimension(num_dims) :: avg_dvdx_int !< Averaged interface \f$\partial v_i/\partial x\f$ (grid dir 1). - real(wp), dimension(num_dims) :: avg_dvdy_int !< Averaged interface \f$\partial v_i/\partial y\f$ (grid dir 2). - real(wp), dimension(num_dims) :: avg_dvdz_int !< Averaged interface \f$\partial v_i/\partial z\f$ (grid dir 3). - !> Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. - real(wp), dimension(num_dims) :: vel_src_int - !> Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). - real(wp), dimension(num_dims) :: stress_vector_shear - #:endif - real(wp) :: stress_normal_bulk !< Normal bulk stress component \f$\sigma_{NN}\f$ on N-face. - real(wp) :: Re_s, Re_b !< Effective interface shear and bulk Reynolds numbers. - real(wp) :: r_eff !< Effective radius at interface for cylindrical terms. - real(wp) :: div_v_term_const !< Common term \f$-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s\f$ for shear stress diagonal. - real(wp) :: divergence_cyl !< Full divergence \f$\nabla \cdot \mathbf{v}\f$ in cylindrical coordinates. - integer :: j, k, l !< Loop iterators for \f$x, y, z\f$ grid directions. - integer :: i_vel !< Loop iterator for velocity components. - integer :: idx_rp(3) !< Indices \f$(j,k,l)\f$ of 'right' point for averaging. - real(wp) :: gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz - real(wp), dimension(2) :: Re_nn - real(wp), dimension(num_fluids) :: alpha_avg - integer :: fl - - $:GPU_PARALLEL_LOOP(collapse=3, private='[idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, Re_s, Re_b, & - & vel_src_int, r_eff, divergence_cyl, stress_vector_shear, stress_normal_bulk, div_v_term_const, & - & gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz, Re_nn, alpha_avg, fl]') - do l = iz%beg, iz%end - do k = iy%beg, iy%end - do j = ix%beg, ix%end - ! Determine indices for the 'right' state for averaging across the interface - idx_rp = [j, k, l] - idx_rp(norm_dir) = idx_rp(norm_dir) + 1 - - ! Average velocities and their derivatives at the interface For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ - ! radial (r_cyl), z-dir ~ azimuthal (theta_cyl) - $:GPU_LOOP(parallelism='[seq]') - do i_vel = 1, num_dims - avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - - avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + dvelR_dx_vf(i_vel)%sf(idx_rp(1), & - & idx_rp(2), idx_rp(3))) - if (num_dims > 1) then - avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + dvelR_dy_vf(i_vel)%sf(idx_rp(1), & - & idx_rp(2), idx_rp(3))) - else - avg_dvdy_int(i_vel) = 0.0_wp - end if - if (num_dims > 2) then - avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + dvelR_dz_vf(i_vel)%sf(idx_rp(1), & - & idx_rp(2), idx_rp(3))) - else - avg_dvdz_int(i_vel) = 0.0_wp - end if - end do - - ! Non-Newtonian effective shear rate from grid-direction strain components. - ! NOTE: curvature corrections to gamma_dot (e.g. hoop strain) are not included - ! here - a documented first-version limitation. The Reynolds override and the - ! Newtonian path below are exact. - if (any_non_newtonian) then - D_xx = avg_dvdx_int(1); D_yy = 0._wp; D_zz = 0._wp - D_xy = 0._wp; D_xz = 0._wp; D_yz = 0._wp - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - D_yy = avg_dvdy_int(2) - D_xy = 0.5_wp*(avg_dvdy_int(1) + avg_dvdx_int(2)) - end if - #:endif - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - D_zz = avg_dvdz_int(3) - D_xz = 0.5_wp*(avg_dvdz_int(1) + avg_dvdx_int(3)) - D_yz = 0.5_wp*(avg_dvdz_int(2) + avg_dvdy_int(3)) - end if - #:endif - gamma_dot = f_compute_shear_rate_from_components(D_xx, D_yy, D_zz, D_xy, D_xz, D_yz) - do fl = 1, num_fluids - alpha_avg(fl) = 0.5_wp*(q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(j, k, & - & l) + q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) - ! Raw cell-centered alphas can under/overshoot near interfaces; clamp to [0,1] - alpha_avg(fl) = min(max(alpha_avg(fl), 0._wp), 1._wp) - end do - call s_compute_mixture_inv_re(alpha_avg, gamma_dot, Res_gs, Re_nn) - end if - - ! Get Re numbers and interface velocity for viscous work - select case (norm_dir) - case (1) ! x-face (axial face in z_cyl direction) - if (any_non_newtonian) then - Re_s = Re_nn(1) - Re_b = Re_nn(2) - else - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - end if - vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) - r_eff = y_cc(k) - case (2) ! y-face (radial face in r_cyl direction) - if (any_non_newtonian) then - Re_s = Re_nn(1) - Re_b = Re_nn(2) - else - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - end if - vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) - r_eff = y_cb(k) - case (3) ! z-face (azimuthal face in theta_cyl direction) - if (any_non_newtonian) then - Re_s = Re_nn(1) - Re_b = Re_nn(2) - else - Re_s = Re_avg_rsx_vf(j, k, l, 1) - Re_b = Re_avg_rsx_vf(j, k, l, 2) - end if - vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) - r_eff = y_cc(k) - end select - - ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff - if (num_dims > 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff - #:endif - end if - #:endif - - stress_vector_shear = 0.0_wp - stress_normal_bulk = 0.0_wp - - if (shear_stress) then - div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s - - select case (norm_dir) - case (1) ! X-face (axial normal, z_cyl) - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - if (num_dims > 1) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - #:endif - end if - if (num_dims > 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - #:endif - end if - case (2) ! Y-face (radial normal, r_cyl) - if (num_dims > 1) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s - stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const - if (num_dims > 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3) & - & )/Re_s - #:endif - end if - #:endif - else - stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const - end if - case (3) ! Z-face (azimuthal normal, theta_cyl) - if (num_dims > 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s - stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s - stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s & - & + div_v_term_const - #:endif - end if - end select - - $:GPU_LOOP(parallelism='[seq]') - do i_vel = 1, num_dims - flux_src_vf(eqn_idx%mom%beg + i_vel - 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + i_vel - 1)%sf(j, & - & k, l) - stress_vector_shear(i_vel) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) - end do - end if - - if (bulk_stress) then - stress_normal_bulk = divergence_cyl/Re_b - - flux_src_vf(eqn_idx%mom%beg + norm_dir - 1)%sf(j, k, & - & l) = flux_src_vf(eqn_idx%mom%beg + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - vel_src_int(norm_dir)*stress_normal_bulk - end if - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - end subroutine s_compute_cylindrical_viscous_source_flux - - !> Compute Cartesian viscous source flux contributions for momentum and energy - subroutine s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, dvelR_dx_vf, dvelR_dy_vf, & - - & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir) - - ! Arguments - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf - type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - integer, intent(in) :: norm_dir - - ! Local variables - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3, 3) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(3, 3) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(3, 3) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(3) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - #:else - real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. - real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. - real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. - #:endif - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - real(wp) :: Re_shear !< Interface shear Reynolds number. - real(wp) :: Re_bulk !< Interface bulk Reynolds number. - integer :: j_loop !< Physical x-index loop iterator. - integer :: k_loop !< Physical y-index loop iterator. - integer :: l_loop !< Physical z-index loop iterator. - integer :: i_dim !< Generic dimension/component iterator. - integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). - real(wp) :: divergence_v !< Velocity divergence at interface. - real(wp) :: gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz - real(wp), dimension(2) :: Re_nn - real(wp), dimension(num_fluids) :: alpha_avg - integer :: fl - - $:GPU_PARALLEL_LOOP(collapse=3, private='[idx_right_phys, vel_grad_avg, current_tau_shear, current_tau_bulk, & - & vel_src_at_interface, Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx, gamma_dot, D_xx, D_yy, & - & D_zz, D_xy, D_xz, D_yz, Re_nn, alpha_avg, fl]') - do l_loop = isz%beg, isz%end - do k_loop = isy%beg, isy%end - do j_loop = isx%beg, isx%end - idx_right_phys(1) = j_loop - idx_right_phys(2) = k_loop - idx_right_phys(3) = l_loop - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - vel_grad_avg = 0.0_wp - do vel_comp_idx = 1, num_dims - vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, & - & l_loop) + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))) - if (num_dims > 1) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, & - & l_loop) + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))) - #:endif - end if - if (num_dims > 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, & - & l_loop) + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))) - #:endif - end if - end do - - if (any_non_newtonian) then - D_xx = vel_grad_avg(1, 1); D_yy = 0._wp; D_zz = 0._wp - D_xy = 0._wp; D_xz = 0._wp; D_yz = 0._wp - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - D_yy = vel_grad_avg(2, 2) - D_xy = 0.5_wp*(vel_grad_avg(1, 2) + vel_grad_avg(2, 1)) - end if - #:endif - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - D_zz = vel_grad_avg(3, 3) - D_xz = 0.5_wp*(vel_grad_avg(1, 3) + vel_grad_avg(3, 1)) - D_yz = 0.5_wp*(vel_grad_avg(2, 3) + vel_grad_avg(3, 2)) - end if - #:endif - gamma_dot = f_compute_shear_rate_from_components(D_xx, D_yy, D_zz, D_xy, D_xz, D_yz) - do fl = 1, num_fluids - alpha_avg(fl) = 0.5_wp*(q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(j_loop, k_loop, & - & l_loop) + q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(idx_right_phys(1), idx_right_phys(2), & - & idx_right_phys(3))) - ! Raw cell-centered alphas can under/overshoot near interfaces; clamp to [0,1] - alpha_avg(fl) = min(max(alpha_avg(fl), 0._wp), 1._wp) - end do - call s_compute_mixture_inv_re(alpha_avg, gamma_dot, Res_gs, Re_nn) - end if - - divergence_v = 0.0_wp - do i_dim = 1, num_dims - divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) - end do - - vel_src_at_interface = 0.0_wp - if (norm_dir == 1) then - if (any_non_newtonian) then - Re_shear = Re_nn(1) - Re_bulk = Re_nn(2) - else - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - end if - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else if (norm_dir == 2) then - if (any_non_newtonian) then - Re_shear = Re_nn(1) - Re_bulk = Re_nn(2) - else - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - end if - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - else - if (any_non_newtonian) then - Re_shear = Re_nn(1) - Re_bulk = Re_nn(2) - else - Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) - Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) - end if - do i_dim = 1, num_dims - vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) - end do - end if - - if (shear_stress) then - ! current_tau_shear = 0.0_wp - call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) - - do i_dim = 1, num_dims - flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & - & l_loop) = flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & - & l_loop) - current_tau_shear(norm_dir, i_dim) - - flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, l_loop) = flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) - end do - end if - - if (bulk_stress) then - ! current_tau_bulk = 0.0_wp - call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) - - do i_dim = 1, num_dims - flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & - & l_loop) = flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & - & l_loop) - current_tau_bulk(norm_dir, i_dim) - - flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, l_loop) = flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, & - & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) - end do - end if - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - end subroutine s_compute_cartesian_viscous_source_flux - - !> Compute shear stress tensor components - subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) - - $:GPU_ROUTINE(parallelism='[seq]') - - ! Arguments - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3, 3), intent(in) :: vel_grad_avg - real(wp), dimension(3, 3), intent(out) :: tau_shear_out - #:else - real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out - #:endif - real(wp), intent(in) :: Re_shear - real(wp), intent(in) :: divergence_v - - ! Local variables - integer :: i_dim !< Loop iterator for face normal. - integer :: j_dim !< Loop iterator for force component direction. - tau_shear_out = 0.0_wp - - do i_dim = 1, num_dims - do j_dim = 1, num_dims - tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear - if (i_dim == j_dim) then - tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - (2.0_wp/3.0_wp)*divergence_v/Re_shear - end if - end do - end do - - end subroutine s_calculate_shear_stress_tensor - - !> Compute bulk stress tensor components (diagonal only) - subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) - - $:GPU_ROUTINE(parallelism='[seq]') - - ! Arguments - real(wp), intent(in) :: Re_bulk - real(wp), intent(in) :: divergence_v - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3, 3), intent(out) :: tau_bulk_out - #:else - real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out - #:endif - - ! Local variables - integer :: i_dim !< Loop iterator for diagonal components. - tau_bulk_out = 0.0_wp - - do i_dim = 1, num_dims - tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk - end do - - end subroutine s_calculate_bulk_stress_tensor - - !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver - subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) - - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - integer :: i, j, k, l !< Generic loop iterators - ! Reshaping Outputted Data in y-direction - - if (norm_dir == 2) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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_rsx_vf(k, j, l, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (cyl_coord) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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_rsx_vf(k, j, l, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - $:GPU_PARALLEL_LOOP(collapse=3) - do l = is3%beg, is3%end - do j = is1%beg, is1%end - do k = is2%beg, is2%end - flux_src_vf(eqn_idx%adv%beg)%sf(k, j, l) = flux_src_rsx_vf(k, j, l, eqn_idx%adv%beg) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end - 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_rsx_vf(k, j, l, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - ! Reshaping Outputted Data in z-direction - else if (norm_dir == 3) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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_rsx_vf(l, k, j, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - if (grid_geometry == 3) then - $:GPU_PARALLEL_LOOP(collapse=4) - 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_rsx_vf(l, k, j, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - $:GPU_PARALLEL_LOOP(collapse=3) - do j = is1%beg, is1%end - do k = is2%beg, is2%end - do l = is3%beg, is3%end - flux_src_vf(eqn_idx%adv%beg)%sf(l, k, j) = flux_src_rsx_vf(l, k, j, eqn_idx%adv%beg) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end - 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_rsx_vf(l, k, j, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - else if (norm_dir == 1) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = 1, sys_size - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_vf(i)%sf(j, k, l) = flux_rsx_vf(j, k, l, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - $:GPU_PARALLEL_LOOP(collapse=3) - do l = is3%beg, is3%end - do k = is2%beg, is2%end - do j = is1%beg, is1%end - flux_src_vf(eqn_idx%adv%beg)%sf(j, k, l) = flux_src_rsx_vf(j, k, l, eqn_idx%adv%beg) - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - - if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then - $:GPU_PARALLEL_LOOP(collapse=4) - do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end - 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(j, k, l, i) - end do - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - end if - - end subroutine s_finalize_riemann_solver - !> Module deallocation and/or disassociation procedures impure subroutine s_finalize_riemann_solvers_module diff --git a/src/simulation/m_riemann_state.fpp b/src/simulation/m_riemann_state.fpp new file mode 100644 index 0000000000..595f785d39 --- /dev/null +++ b/src/simulation/m_riemann_state.fpp @@ -0,0 +1,1167 @@ +!> +!! @file +!! @brief Contains module m_riemann_state + +!> @brief Shared Riemann-solver module state and the per-sweep setup, state-buffer population, viscous source flux, and finalization +!! helpers +#:include 'case.fpp' +#:include 'macros.fpp' + +module m_riemann_state + + use m_derived_types + use m_global_parameters + use m_constants, only: riemann_solver_hll, riemann_solver_hlld + use m_hb_function + + implicit none + + !> The cell-boundary values of the fluxes (src - source) that are computed through the chosen Riemann problem solver, and the + !! direct evaluation of source terms, by using the left and right states given in qK_prim_rs_vf, dqK_prim_ds_vf where ds = dx, + !! dy or dz. + !> @{ + real(wp), allocatable, dimension(:,:,:,:) :: flux_rsx_vf, flux_src_rsx_vf + $:GPU_DECLARE(create='[flux_rsx_vf, flux_src_rsx_vf]') + !> @} + + !> The cell-boundary values of the geometrical source flux that are computed through the chosen Riemann problem solver by using + !! the left and right states given in qK_prim_rs_vf. Currently 2D axisymmetric for inviscid only. + !> @{ + real(wp), allocatable, dimension(:,:,:,:) :: flux_gsrc_rsx_vf + $:GPU_DECLARE(create='[flux_gsrc_rsx_vf]') + !> @} + + ! Cell-boundary velocity from Riemann solution; used for source flux + + real(wp), allocatable, dimension(:,:,:,:) :: vel_src_rsx_vf + $:GPU_DECLARE(create='[vel_src_rsx_vf]') + + real(wp), allocatable, dimension(:,:,:,:) :: mom_sp_rsx_vf + $:GPU_DECLARE(create='[mom_sp_rsx_vf]') + + real(wp), allocatable, dimension(:,:,:,:) :: Re_avg_rsx_vf + $:GPU_DECLARE(create='[Re_avg_rsx_vf]') + + !> @name Indical bounds in the s1-, s2- and s3-directions + !> @{ + type(int_bounds_info) :: is1, is2, is3 + type(int_bounds_info) :: isx, isy, isz + !> @} + + $:GPU_DECLARE(create='[is1, is2, is3, isx, isy, isz]') + + real(wp), allocatable, dimension(:) :: Gs_rs + $:GPU_DECLARE(create='[Gs_rs]') + + real(wp), allocatable, dimension(:,:) :: Res_gs + $:GPU_DECLARE(create='[Res_gs]') + +contains + + !> Dispatch to the subroutines that are utilized to compute the viscous source fluxes for either Cartesian or cylindrical + !! geometries. For more information please refer to: 1) s_compute_cartesian_viscous_source_flux 2) + !! s_compute_cylindrical_viscous_source_flux + subroutine s_compute_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, dvelR_dy_vf, & + + & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_vels), intent(in) :: velL_vf, velR_vf, dvelL_dx_vf, dvelR_dx_vf, dvelL_dy_vf, & + & dvelR_dy_vf, dvelL_dz_vf, dvelR_dz_vf + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + if (grid_geometry == 3) then + call s_compute_cylindrical_viscous_source_flux(velL_vf, dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, velR_vf, dvelR_dx_vf, & + & dvelR_dy_vf, dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir, ix, iy, iz) + else + call s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, dvelR_dx_vf, dvelR_dy_vf, & + & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir) + end if + + end subroutine s_compute_viscous_source_flux + + !> Populate the left and right Riemann state variable buffers based on boundary conditions + subroutine s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, & + + & dqL_prim_dy_vf, dqL_prim_dz_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_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 + + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + integer :: i, j, k, l !< Generic loop iterator + + if (norm_dir == 1) then + is1 = ix; is2 = iy; is3 = iz + dir_idx = (/1, 2, 3/); dir_flg = (/1._wp, 0._wp, 0._wp/) + else if (norm_dir == 2) then + is1 = iy; is2 = ix; is3 = iz + dir_idx = (/2, 1, 3/); dir_flg = (/0._wp, 1._wp, 0._wp/) + else + is1 = iz; is2 = iy; is3 = ix + dir_idx = (/3, 1, 2/); dir_flg = (/0._wp, 0._wp, 1._wp/) + end if + + $:GPU_UPDATE(device='[is1, is2, is3]') + + if (elasticity) then + if (norm_dir == 1) then + dir_idx_tau = (/1, 2, 4/) + else if (norm_dir == 2) then + dir_idx_tau = (/3, 2, 5/) + else + dir_idx_tau = (/6, 4, 5/) + end if + end if + + isx = ix; isy = iy; isz = iz + ! for stuff in the same module + $:GPU_UPDATE(device='[isx, isy, isz]') + ! for stuff in different modules + $:GPU_UPDATE(device='[dir_idx, dir_flg, dir_idx_tau]') + + ! Population of Buffers in x-direction + if (norm_dir == 1) then + if (bc_x%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rsx_vf(-1, k, l, i) = qR_prim_rsx_vf(0, k, l, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (n > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (p > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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_GPU_PARALLEL_LOOP() + end if + end if + end if + end if + + if (bc_x%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rsx_vf(m + 1, k, l, i) = qL_prim_rsx_vf(m, k, l, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (n > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (p > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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_GPU_PARALLEL_LOOP() + end if + end if + end if + end if + ! END: Population of Buffers in x-direction + + ! Population of Buffers in y-direction + else if (norm_dir == 2) then + if (bc_y%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qL_prim_rsx_vf(k, -1, l, i) = qR_prim_rsx_vf(k, 0, l, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (p > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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_GPU_PARALLEL_LOOP() + end if + end if + end if + + if (bc_y%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + qR_prim_rsx_vf(k, n + 1, l, i) = qL_prim_rsx_vf(k, n, l, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + if (p > 0) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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_GPU_PARALLEL_LOOP() + end if + end if + end if + ! END: Population of Buffers in y-direction + + ! Population of Buffers in z-direction + else + if (bc_z%beg == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at beginning + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do k = is2%beg, is2%end + do l = is3%beg, is3%end + qL_prim_rsx_vf(l, k, -1, i) = qR_prim_rsx_vf(l, k, 0, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqL_prim_dx_vf(i)%sf(j, k, -1) = dqR_prim_dx_vf(i)%sf(j, k, 0) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqL_prim_dy_vf(i)%sf(j, k, -1) = dqR_prim_dy_vf(i)%sf(j, k, 0) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + do k = isy%beg, isy%end + do j = isx%beg, isx%end + dqL_prim_dz_vf(i)%sf(j, k, -1) = dqR_prim_dz_vf(i)%sf(j, k, 0) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + end if + + if (bc_z%end == BC_RIEMANN_EXTRAP) then ! Riemann state extrap. BC at end + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = 1, sys_size + do k = is2%beg, is2%end + do l = is3%beg, is3%end + qR_prim_rsx_vf(l, k, p + 1, i) = qL_prim_rsx_vf(l, k, p, i) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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 + $:END_GPU_PARALLEL_LOOP() + + $:GPU_PARALLEL_LOOP(collapse=3) + do i = eqn_idx%mom%beg, eqn_idx%mom%end + 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_GPU_PARALLEL_LOOP() + end if + end if + end if + ! END: Population of Buffers in z-direction + + end subroutine s_populate_riemann_states_variables_buffers + + !> Set up the chosen Riemann solver algorithm for the current direction + subroutine s_initialize_riemann_solver(flux_src_vf, norm_dir) + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + integer, intent(in) :: norm_dir + integer :: i, j, k, l !< Generic loop iterators + + ! Reshaping Inputted Data in x-direction + + if (norm_dir == 1) then + if (viscous .or. (surface_tension)) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%mom%beg, eqn_idx%E + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(i)%sf(j, k, l) = 0._wp + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (chem_params%diffusion) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%E, eqn_idx%species%end + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then + flux_src_vf(i)%sf(j, k, l) = 0._wp + end if + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (qbmm) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = 1, 4 + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + 1 + mom_sp_rsx_vf(j, k, l, i) = mom_sp(i)%sf(j, k, l) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + ! Reshaping Inputted Data in y-direction + else if (norm_dir == 2) then + if (viscous .or. (surface_tension)) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%mom%beg, eqn_idx%E + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(i)%sf(k, j, l) = 0._wp + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (chem_params%diffusion) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%E, eqn_idx%species%end + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then + flux_src_vf(i)%sf(k, j, l) = 0._wp + end if + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (qbmm) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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(k, j, l, i) = mom_sp(i)%sf(k, j, l) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + ! Reshaping Inputted Data in z-direction + else + if (viscous .or. (surface_tension)) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%mom%beg, eqn_idx%E + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(i)%sf(l, k, j) = 0._wp + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (chem_params%diffusion) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%E, eqn_idx%species%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + if (i == eqn_idx%E .or. i >= eqn_idx%species%beg) then + flux_src_vf(i)%sf(l, k, j) = 0._wp + end if + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + if (qbmm) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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(l, k, j, i) = mom_sp(i)%sf(l, k, j) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + end if + + end subroutine s_initialize_riemann_solver + + !> Compute cylindrical viscous source flux contributions for momentum and energy + 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, q_prim_vf, norm_dir, ix, iy, iz) + + type(scalar_field), dimension(num_dims), intent(in) :: velL_vf, velR_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: avg_v_int !< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). + real(wp), dimension(3) :: avg_dvdx_int !< Averaged interface \f$\partial v_i/\partial x\f$ (grid dir 1). + real(wp), dimension(3) :: avg_dvdy_int !< Averaged interface \f$\partial v_i/\partial y\f$ (grid dir 2). + real(wp), dimension(3) :: avg_dvdz_int !< Averaged interface \f$\partial v_i/\partial z\f$ (grid dir 3). + real(wp), dimension(3) :: vel_src_int !< Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. + + !> Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + real(wp), dimension(3) :: stress_vector_shear + #:else + real(wp), dimension(num_dims) :: avg_v_int !< Averaged interface velocity (\f$v_x, v_y, v_z\f$) (grid directions). + real(wp), dimension(num_dims) :: avg_dvdx_int !< Averaged interface \f$\partial v_i/\partial x\f$ (grid dir 1). + real(wp), dimension(num_dims) :: avg_dvdy_int !< Averaged interface \f$\partial v_i/\partial y\f$ (grid dir 2). + real(wp), dimension(num_dims) :: avg_dvdz_int !< Averaged interface \f$\partial v_i/\partial z\f$ (grid dir 3). + !> Interface velocity (\f$v_1,v_2,v_3\f$) (grid directions) for viscous work. + real(wp), dimension(num_dims) :: vel_src_int + !> Shear stress vector (\f$\sigma_{N1}, \sigma_{N2}, \sigma_{N3}\f$) on N-face (grid directions). + real(wp), dimension(num_dims) :: stress_vector_shear + #:endif + real(wp) :: stress_normal_bulk !< Normal bulk stress component \f$\sigma_{NN}\f$ on N-face. + real(wp) :: Re_s, Re_b !< Effective interface shear and bulk Reynolds numbers. + real(wp) :: r_eff !< Effective radius at interface for cylindrical terms. + real(wp) :: div_v_term_const !< Common term \f$-(2/3)(\nabla \cdot \mathbf{v}) / \text{Re}_s\f$ for shear stress diagonal. + real(wp) :: divergence_cyl !< Full divergence \f$\nabla \cdot \mathbf{v}\f$ in cylindrical coordinates. + integer :: j, k, l !< Loop iterators for \f$x, y, z\f$ grid directions. + integer :: i_vel !< Loop iterator for velocity components. + integer :: idx_rp(3) !< Indices \f$(j,k,l)\f$ of 'right' point for averaging. + real(wp) :: gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz + real(wp), dimension(2) :: Re_nn + real(wp), dimension(num_fluids) :: alpha_avg + integer :: fl + + $:GPU_PARALLEL_LOOP(collapse=3, private='[idx_rp, avg_v_int, avg_dvdx_int, avg_dvdy_int, avg_dvdz_int, Re_s, Re_b, & + & vel_src_int, r_eff, divergence_cyl, stress_vector_shear, stress_normal_bulk, div_v_term_const, & + & gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz, Re_nn, alpha_avg, fl]') + do l = iz%beg, iz%end + do k = iy%beg, iy%end + do j = ix%beg, ix%end + ! Determine indices for the 'right' state for averaging across the interface + idx_rp = [j, k, l] + idx_rp(norm_dir) = idx_rp(norm_dir) + 1 + + ! Average velocities and their derivatives at the interface For cylindrical: x-dir ~ axial (z_cyl), y-dir ~ + ! radial (r_cyl), z-dir ~ azimuthal (theta_cyl) + $:GPU_LOOP(parallelism='[seq]') + do i_vel = 1, num_dims + avg_v_int(i_vel) = 0.5_wp*(velL_vf(i_vel)%sf(j, k, l) + velR_vf(i_vel)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + + avg_dvdx_int(i_vel) = 0.5_wp*(dvelL_dx_vf(i_vel)%sf(j, k, l) + dvelR_dx_vf(i_vel)%sf(idx_rp(1), & + & idx_rp(2), idx_rp(3))) + if (num_dims > 1) then + avg_dvdy_int(i_vel) = 0.5_wp*(dvelL_dy_vf(i_vel)%sf(j, k, l) + dvelR_dy_vf(i_vel)%sf(idx_rp(1), & + & idx_rp(2), idx_rp(3))) + else + avg_dvdy_int(i_vel) = 0.0_wp + end if + if (num_dims > 2) then + avg_dvdz_int(i_vel) = 0.5_wp*(dvelL_dz_vf(i_vel)%sf(j, k, l) + dvelR_dz_vf(i_vel)%sf(idx_rp(1), & + & idx_rp(2), idx_rp(3))) + else + avg_dvdz_int(i_vel) = 0.0_wp + end if + end do + + ! Non-Newtonian effective shear rate from grid-direction strain components. + ! NOTE: curvature corrections to gamma_dot (e.g. hoop strain) are not included + ! here - a documented first-version limitation. The Reynolds override and the + ! Newtonian path below are exact. + if (any_non_newtonian) then + D_xx = avg_dvdx_int(1); D_yy = 0._wp; D_zz = 0._wp + D_xy = 0._wp; D_xz = 0._wp; D_yz = 0._wp + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + D_yy = avg_dvdy_int(2) + D_xy = 0.5_wp*(avg_dvdy_int(1) + avg_dvdx_int(2)) + end if + #:endif + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + D_zz = avg_dvdz_int(3) + D_xz = 0.5_wp*(avg_dvdz_int(1) + avg_dvdx_int(3)) + D_yz = 0.5_wp*(avg_dvdz_int(2) + avg_dvdy_int(3)) + end if + #:endif + gamma_dot = f_compute_shear_rate_from_components(D_xx, D_yy, D_zz, D_xy, D_xz, D_yz) + do fl = 1, num_fluids + alpha_avg(fl) = 0.5_wp*(q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(j, k, & + & l) + q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(idx_rp(1), idx_rp(2), idx_rp(3))) + ! Raw cell-centered alphas can under/overshoot near interfaces; clamp to [0,1] + alpha_avg(fl) = min(max(alpha_avg(fl), 0._wp), 1._wp) + end do + call s_compute_mixture_inv_re(alpha_avg, gamma_dot, Res_gs, Re_nn) + end if + + ! Get Re numbers and interface velocity for viscous work + select case (norm_dir) + case (1) ! x-face (axial face in z_cyl direction) + if (any_non_newtonian) then + Re_s = Re_nn(1) + Re_b = Re_nn(2) + else + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + end if + vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) + r_eff = y_cc(k) + case (2) ! y-face (radial face in r_cyl direction) + if (any_non_newtonian) then + Re_s = Re_nn(1) + Re_b = Re_nn(2) + else + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + end if + vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) + r_eff = y_cb(k) + case (3) ! z-face (azimuthal face in theta_cyl direction) + if (any_non_newtonian) then + Re_s = Re_nn(1) + Re_b = Re_nn(2) + else + Re_s = Re_avg_rsx_vf(j, k, l, 1) + Re_b = Re_avg_rsx_vf(j, k, l, 2) + end if + vel_src_int = vel_src_rsx_vf(j, k, l,1:num_dims) + r_eff = y_cc(k) + end select + + ! Divergence in cylindrical coordinates (vx=vz_cyl, vy=vr_cyl, vz=vtheta_cyl) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + divergence_cyl = avg_dvdx_int(1) + avg_dvdy_int(2) + avg_v_int(2)/r_eff + if (num_dims > 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + divergence_cyl = divergence_cyl + avg_dvdz_int(3)/r_eff + #:endif + end if + #:endif + + stress_vector_shear = 0.0_wp + stress_normal_bulk = 0.0_wp + + if (shear_stress) then + div_v_term_const = -(2.0_wp/3.0_wp)*divergence_cyl/Re_s + + select case (norm_dir) + case (1) ! X-face (axial normal, z_cyl) + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + if (num_dims > 1) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + stress_vector_shear(2) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + #:endif + end if + if (num_dims > 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + stress_vector_shear(3) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + #:endif + end if + case (2) ! Y-face (radial normal, r_cyl) + if (num_dims > 1) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + stress_vector_shear(1) = (avg_dvdy_int(1) + avg_dvdx_int(2))/Re_s + stress_vector_shear(2) = (2.0_wp*avg_dvdy_int(2))/Re_s + div_v_term_const + if (num_dims > 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + stress_vector_shear(3) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3) & + & )/Re_s + #:endif + end if + #:endif + else + stress_vector_shear(1) = (2.0_wp*avg_dvdx_int(1))/Re_s + div_v_term_const + end if + case (3) ! Z-face (azimuthal normal, theta_cyl) + if (num_dims > 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + stress_vector_shear(1) = (avg_dvdz_int(1)/r_eff + avg_dvdx_int(3))/Re_s + stress_vector_shear(2) = (avg_dvdz_int(2)/r_eff - avg_v_int(3)/r_eff + avg_dvdy_int(3))/Re_s + stress_vector_shear(3) = (2.0_wp*(avg_dvdz_int(3)/r_eff + avg_v_int(2)/r_eff))/Re_s & + & + div_v_term_const + #:endif + end if + end select + + $:GPU_LOOP(parallelism='[seq]') + do i_vel = 1, num_dims + flux_src_vf(eqn_idx%mom%beg + i_vel - 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + i_vel - 1)%sf(j, & + & k, l) - stress_vector_shear(i_vel) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - vel_src_int(i_vel)*stress_vector_shear(i_vel) + end do + end if + + if (bulk_stress) then + stress_normal_bulk = divergence_cyl/Re_b + + flux_src_vf(eqn_idx%mom%beg + norm_dir - 1)%sf(j, k, & + & l) = flux_src_vf(eqn_idx%mom%beg + norm_dir - 1)%sf(j, k, l) - stress_normal_bulk + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - vel_src_int(norm_dir)*stress_normal_bulk + end if + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + end subroutine s_compute_cylindrical_viscous_source_flux + + !> Compute Cartesian viscous source flux contributions for momentum and energy + subroutine s_compute_cartesian_viscous_source_flux(dvelL_dx_vf, dvelL_dy_vf, dvelL_dz_vf, dvelR_dx_vf, dvelR_dy_vf, & + + & dvelR_dz_vf, flux_src_vf, q_prim_vf, norm_dir) + + ! Arguments + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dx_vf, dvelR_dx_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dy_vf, dvelR_dy_vf + type(scalar_field), dimension(num_dims), intent(in) :: dvelL_dz_vf, dvelR_dz_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_src_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + integer, intent(in) :: norm_dir + + ! Local variables + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3, 3) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(3, 3) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(3, 3) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(3) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + #:else + real(wp), dimension(num_dims, num_dims) :: vel_grad_avg !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: current_tau_shear !< Current shear stress tensor. + real(wp), dimension(num_dims, num_dims) :: current_tau_bulk !< Current bulk stress tensor. + real(wp), dimension(num_dims) :: vel_src_at_interface !< Interface velocities (u,v,w) for viscous work. + #:endif + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + real(wp) :: Re_shear !< Interface shear Reynolds number. + real(wp) :: Re_bulk !< Interface bulk Reynolds number. + integer :: j_loop !< Physical x-index loop iterator. + integer :: k_loop !< Physical y-index loop iterator. + integer :: l_loop !< Physical z-index loop iterator. + integer :: i_dim !< Generic dimension/component iterator. + integer :: vel_comp_idx !< Velocity component iterator (1=u, 2=v, 3=w). + real(wp) :: divergence_v !< Velocity divergence at interface. + real(wp) :: gamma_dot, D_xx, D_yy, D_zz, D_xy, D_xz, D_yz + real(wp), dimension(2) :: Re_nn + real(wp), dimension(num_fluids) :: alpha_avg + integer :: fl + + $:GPU_PARALLEL_LOOP(collapse=3, private='[idx_right_phys, vel_grad_avg, current_tau_shear, current_tau_bulk, & + & vel_src_at_interface, Re_shear, Re_bulk, divergence_v, i_dim, vel_comp_idx, gamma_dot, D_xx, D_yy, & + & D_zz, D_xy, D_xz, D_yz, Re_nn, alpha_avg, fl]') + do l_loop = isz%beg, isz%end + do k_loop = isy%beg, isy%end + do j_loop = isx%beg, isx%end + idx_right_phys(1) = j_loop + idx_right_phys(2) = k_loop + idx_right_phys(3) = l_loop + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + vel_grad_avg = 0.0_wp + do vel_comp_idx = 1, num_dims + vel_grad_avg(vel_comp_idx, 1) = 0.5_wp*(dvelL_dx_vf(vel_comp_idx)%sf(j_loop, k_loop, & + & l_loop) + dvelR_dx_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & + & idx_right_phys(3))) + if (num_dims > 1) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + vel_grad_avg(vel_comp_idx, 2) = 0.5_wp*(dvelL_dy_vf(vel_comp_idx)%sf(j_loop, k_loop, & + & l_loop) + dvelR_dy_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & + & idx_right_phys(3))) + #:endif + end if + if (num_dims > 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + vel_grad_avg(vel_comp_idx, 3) = 0.5_wp*(dvelL_dz_vf(vel_comp_idx)%sf(j_loop, k_loop, & + & l_loop) + dvelR_dz_vf(vel_comp_idx)%sf(idx_right_phys(1), idx_right_phys(2), & + & idx_right_phys(3))) + #:endif + end if + end do + + if (any_non_newtonian) then + D_xx = vel_grad_avg(1, 1); D_yy = 0._wp; D_zz = 0._wp + D_xy = 0._wp; D_xz = 0._wp; D_yz = 0._wp + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + D_yy = vel_grad_avg(2, 2) + D_xy = 0.5_wp*(vel_grad_avg(1, 2) + vel_grad_avg(2, 1)) + end if + #:endif + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + D_zz = vel_grad_avg(3, 3) + D_xz = 0.5_wp*(vel_grad_avg(1, 3) + vel_grad_avg(3, 1)) + D_yz = 0.5_wp*(vel_grad_avg(2, 3) + vel_grad_avg(3, 2)) + end if + #:endif + gamma_dot = f_compute_shear_rate_from_components(D_xx, D_yy, D_zz, D_xy, D_xz, D_yz) + do fl = 1, num_fluids + alpha_avg(fl) = 0.5_wp*(q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(j_loop, k_loop, & + & l_loop) + q_prim_vf(eqn_idx%adv%beg + fl - 1)%sf(idx_right_phys(1), idx_right_phys(2), & + & idx_right_phys(3))) + ! Raw cell-centered alphas can under/overshoot near interfaces; clamp to [0,1] + alpha_avg(fl) = min(max(alpha_avg(fl), 0._wp), 1._wp) + end do + call s_compute_mixture_inv_re(alpha_avg, gamma_dot, Res_gs, Re_nn) + end if + + divergence_v = 0.0_wp + do i_dim = 1, num_dims + divergence_v = divergence_v + vel_grad_avg(i_dim, i_dim) + end do + + vel_src_at_interface = 0.0_wp + if (norm_dir == 1) then + if (any_non_newtonian) then + Re_shear = Re_nn(1) + Re_bulk = Re_nn(2) + else + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + end if + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else if (norm_dir == 2) then + if (any_non_newtonian) then + Re_shear = Re_nn(1) + Re_bulk = Re_nn(2) + else + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + end if + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + else + if (any_non_newtonian) then + Re_shear = Re_nn(1) + Re_bulk = Re_nn(2) + else + Re_shear = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 1) + Re_bulk = Re_avg_rsx_vf(j_loop, k_loop, l_loop, 2) + end if + do i_dim = 1, num_dims + vel_src_at_interface(i_dim) = vel_src_rsx_vf(j_loop, k_loop, l_loop, i_dim) + end do + end if + + if (shear_stress) then + ! current_tau_shear = 0.0_wp + call s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, current_tau_shear) + + do i_dim = 1, num_dims + flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & + & l_loop) = flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & + & l_loop) - current_tau_shear(norm_dir, i_dim) + + flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, l_loop) = flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, & + & l_loop) - vel_src_at_interface(i_dim)*current_tau_shear(norm_dir, i_dim) + end do + end if + + if (bulk_stress) then + ! current_tau_bulk = 0.0_wp + call s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, current_tau_bulk) + + do i_dim = 1, num_dims + flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & + & l_loop) = flux_src_vf(eqn_idx%mom%beg + i_dim - 1)%sf(j_loop, k_loop, & + & l_loop) - current_tau_bulk(norm_dir, i_dim) + + flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, l_loop) = flux_src_vf(eqn_idx%E)%sf(j_loop, k_loop, & + & l_loop) - vel_src_at_interface(i_dim)*current_tau_bulk(norm_dir, i_dim) + end do + end if + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + end subroutine s_compute_cartesian_viscous_source_flux + + !> Compute shear stress tensor components + subroutine s_calculate_shear_stress_tensor(vel_grad_avg, Re_shear, divergence_v, tau_shear_out) + + $:GPU_ROUTINE(parallelism='[seq]') + + ! Arguments + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3, 3), intent(in) :: vel_grad_avg + real(wp), dimension(3, 3), intent(out) :: tau_shear_out + #:else + real(wp), dimension(num_dims, num_dims), intent(in) :: vel_grad_avg + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_shear_out + #:endif + real(wp), intent(in) :: Re_shear + real(wp), intent(in) :: divergence_v + + ! Local variables + integer :: i_dim !< Loop iterator for face normal. + integer :: j_dim !< Loop iterator for force component direction. + tau_shear_out = 0.0_wp + + do i_dim = 1, num_dims + do j_dim = 1, num_dims + tau_shear_out(i_dim, j_dim) = (vel_grad_avg(j_dim, i_dim) + vel_grad_avg(i_dim, j_dim))/Re_shear + if (i_dim == j_dim) then + tau_shear_out(i_dim, j_dim) = tau_shear_out(i_dim, j_dim) - (2.0_wp/3.0_wp)*divergence_v/Re_shear + end if + end do + end do + + end subroutine s_calculate_shear_stress_tensor + + !> Compute bulk stress tensor components (diagonal only) + subroutine s_calculate_bulk_stress_tensor(Re_bulk, divergence_v, tau_bulk_out) + + $:GPU_ROUTINE(parallelism='[seq]') + + ! Arguments + real(wp), intent(in) :: Re_bulk + real(wp), intent(in) :: divergence_v + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3, 3), intent(out) :: tau_bulk_out + #:else + real(wp), dimension(num_dims, num_dims), intent(out) :: tau_bulk_out + #:endif + + ! Local variables + integer :: i_dim !< Loop iterator for diagonal components. + tau_bulk_out = 0.0_wp + + do i_dim = 1, num_dims + tau_bulk_out(i_dim, i_dim) = divergence_v/Re_bulk + end do + + end subroutine s_calculate_bulk_stress_tensor + + !> Deallocation and/or disassociation procedures that are needed to finalize the selected Riemann problem solver + subroutine s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + integer :: i, j, k, l !< Generic loop iterators + ! Reshaping Outputted Data in y-direction + + if (norm_dir == 2) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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_rsx_vf(k, j, l, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (cyl_coord) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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_rsx_vf(k, j, l, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + $:GPU_PARALLEL_LOOP(collapse=3) + do l = is3%beg, is3%end + do j = is1%beg, is1%end + do k = is2%beg, is2%end + flux_src_vf(eqn_idx%adv%beg)%sf(k, j, l) = flux_src_rsx_vf(k, j, l, eqn_idx%adv%beg) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end + 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_rsx_vf(k, j, l, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + ! Reshaping Outputted Data in z-direction + else if (norm_dir == 3) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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_rsx_vf(l, k, j, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + if (grid_geometry == 3) then + $:GPU_PARALLEL_LOOP(collapse=4) + 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_rsx_vf(l, k, j, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + $:GPU_PARALLEL_LOOP(collapse=3) + do j = is1%beg, is1%end + do k = is2%beg, is2%end + do l = is3%beg, is3%end + flux_src_vf(eqn_idx%adv%beg)%sf(l, k, j) = flux_src_rsx_vf(l, k, j, eqn_idx%adv%beg) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end + 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_rsx_vf(l, k, j, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + else if (norm_dir == 1) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = 1, sys_size + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_vf(i)%sf(j, k, l) = flux_rsx_vf(j, k, l, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + $:GPU_PARALLEL_LOOP(collapse=3) + do l = is3%beg, is3%end + do k = is2%beg, is2%end + do j = is1%beg, is1%end + flux_src_vf(eqn_idx%adv%beg)%sf(j, k, l) = flux_src_rsx_vf(j, k, l, eqn_idx%adv%beg) + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + + if (riemann_solver == riemann_solver_hll .or. riemann_solver == riemann_solver_hlld) then + $:GPU_PARALLEL_LOOP(collapse=4) + do i = eqn_idx%adv%beg + 1, eqn_idx%adv%end + 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(j, k, l, i) + end do + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + end if + + end subroutine s_finalize_riemann_solver + +end module m_riemann_state From 0d92a7cc3d0874f0f54cfc7c86259be60c60c6ee Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:17:38 -0400 Subject: [PATCH 06/11] src: split s_hlld_riemann_solver into m_riemann_solver_hlld NFC, pure motion (calibration commit for the solver extractions). The solver body accesses flux_rsx_vf, flux_src_rsx_vf, is1/2/3 by host association and calls the per-sweep lifecycle helpers, both now use-associated from m_riemann_state. Core re-exports s_hlld_riemann_solver through its existing public list. Statement-multiset union vs the pre-split file differs only by module boilerplate; GPU-directive census md5 unchanged; declare-target scoping verified for all files. --- docs/module_categories.json | 1 + src/simulation/m_riemann_solver_hlld.fpp | 275 +++++++++++++++++++++++ src/simulation/m_riemann_solvers.fpp | 256 +-------------------- 3 files changed, 277 insertions(+), 255 deletions(-) create mode 100644 src/simulation/m_riemann_solver_hlld.fpp diff --git a/docs/module_categories.json b/docs/module_categories.json index 3bef694fef..50b3579398 100644 --- a/docs/module_categories.json +++ b/docs/module_categories.json @@ -7,6 +7,7 @@ "m_weno", "m_riemann_solvers", "m_riemann_state", + "m_riemann_solver_hlld", "m_muscl", "m_variables_conversion", "m_thinc" diff --git a/src/simulation/m_riemann_solver_hlld.fpp b/src/simulation/m_riemann_solver_hlld.fpp new file mode 100644 index 0000000000..b418ed4a59 --- /dev/null +++ b/src/simulation/m_riemann_solver_hlld.fpp @@ -0,0 +1,275 @@ +!> +!! @file +!! @brief Contains module m_riemann_solver_hlld + +!> @brief HLLD approximate Riemann solver for MHD, Miyoshi & Kusano JCP (2005) +#:include 'case.fpp' +#:include 'macros.fpp' + +module m_riemann_solver_hlld + + use m_derived_types + use m_global_parameters + use m_variables_conversion + use m_riemann_state + + implicit none + +contains + + !> HLLD Riemann solver for MHD, Miyoshi & Kusano JCP (2005) + subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & + & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + ! Local variables: + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R + #:else + real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R + #:endif + type(riemann_states_vec3) :: vel + type(riemann_states) :: rho, pres, E, H_no_mag + type(riemann_states) :: gamma, pi_inf, qv + type(riemann_states) :: vel_rms + type(riemann_states_vec3) :: B + type(riemann_states) :: c, c_fast, pres_mag + + ! HLLD speeds and intermediate state variables: + real(wp) :: s_L, s_R, s_M, s_starL, s_starR + real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR + real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR + real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld + + ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) Note: vel and B are permutated, so vel(1) is the + ! normal velocity, and x is the normal direction Note: Bx is omitted as the magnetic flux is always zero in the normal + ! direction + + real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx + real(wp) :: vL_star, vR_star, wL_star, wR_star + real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double + integer :: i, j, k, l + + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) + + call s_initialize_riemann_solver(flux_src_vf, norm_dir) + + #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & + [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & + (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & + (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] + #:set SV = STENCIL_VAR + #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) + if (norm_dir == ${NORM_DIR}$) then + $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, & + & H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, U_L, U_R, U_starL, U_starR, & + & U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld, s_L, s_R, s_M, s_starL, s_starR, & + & pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR, sqrt_rhoL_star, & + & sqrt_rhoR_star, denom_ds, sign_Bx, vL_star, vR_star, wL_star, wR_star, v_double, w_double, & + & By_double, Bz_double, E_doubleL, E_doubleR, E_double]', copyin='[norm_dir]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + ! (1) Extract the left/right primitive states + do i = 1, eqn_idx%cont%end + alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) + alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic + do i = 1, num_vels + vel%L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) + vel%R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + dir_idx(i)) + end do + + vel_rms%L = sum(vel%L**2._wp) + vel_rms%R = sum(vel%R**2._wp) + + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + pres%L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres%R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated + B%L = [Bx0, qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg), qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + 1)] + B%R = [Bx0, qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg), qR_prim_rsx_vf(${SF(' + 1')}$, & + & eqn_idx%B%beg + 1)] + else ! 2D/3D: Bx, By, Bz as variables + B%L = [qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(1) - 1), qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + dir_idx(2) - 1), qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + dir_idx(3) - 1)] + B%R = [qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(1) - 1), & + & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(2) - 1), & + & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(3) - 1)] + end if + end if + + ! Sum properties of all fluid components + rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp + rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho%L = rho%L + alpha_rho_L(i) + gamma%L = gamma%L + alpha_L(i)*gammas(i) + pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) + qv%L = qv%L + alpha_rho_L(i)*qvs(i) + + rho%R = rho%R + alpha_rho_R(i) + gamma%R = gamma%R + alpha_R(i)*gammas(i) + pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) + qv%R = qv%R + alpha_rho_R(i)*qvs(i) + end do + + pres_mag%L = 0.5_wp*sum(B%L**2._wp) + pres_mag%R = 0.5_wp*sum(B%R**2._wp) + E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L + E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy + H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L + ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R + + ! (2) Compute fast wave speeds + call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, & + & 0._wp, c%L, qv%L) + call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, & + & 0._wp, c%R, qv%R) + call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) + call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) + + ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] + s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) + s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) + + pTot_L = pres%L + pres_mag%L + pTot_R = pres%R + pres_mag%R + + s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/((s_R & + & - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) + + ! (4) Compute star state variables + rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) + rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) + p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) + E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) + E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) + + ! (5) Compute left/right state vectors and fluxes + U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] + U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] + U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] + U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] + + ! Compute the left/right fluxes + F_L(1) = U_L(2) + F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L + F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) + F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) + F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) + + F_R(1) = U_R(2) + F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R + F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) + F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) + F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) + ! HLLD star-state fluxes via HLL jump relation + F_starL = F_L + s_L*(U_starL - U_L) + F_starR = F_R + s_R*(U_starR - U_R) + ! Alfven wave speeds bounding the rotational discontinuities + s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) + s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) + ! HLLD double-star (intermediate) states across rotational discontinuities + sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) + vL_star = vel%L(2); wL_star = vel%L(3) + vR_star = vel%R(2); wR_star = vel%R(3) + + ! (6) Compute the double-star states [Miyoshi Eqns. (59)-(62)] + denom_ds = sqrt_rhoL_star + sqrt_rhoR_star + sign_Bx = sign(1._wp, B%L(1)) + v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds + w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds + By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star & + & - vL_star)*sign_Bx)/denom_ds + Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star & + & - wL_star)*sign_Bx)/denom_ds + + E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double & + & + w_double*Bz_double))*sign_Bx + E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double & + & + w_double*Bz_double))*sign_Bx + E_double = 0.5_wp*(E_doubleL + E_doubleR) + + U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, & + & E_double] + U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*v_double, rhoR_star*w_double, By_double, Bz_double, & + & E_double] + + ! Select HLLD flux region + if (0.0_wp <= s_L) then + F_hlld = F_L + else if (0.0_wp <= s_starL) then + F_hlld = F_L + s_L*(U_starL - U_L) + else if (0.0_wp <= s_M) then + F_hlld = F_starL + s_starL*(U_doubleL - U_starL) + else if (0.0_wp <= s_starR) then + F_hlld = F_starR + s_starR*(U_doubleR - U_starR) + else if (0.0_wp <= s_R) then + F_hlld = F_R + s_R*(U_starR - U_R) + else + F_hlld = F_R + end if + + ! (12) Write HLLD flux to output arrays + flux_rsx_vf(${SF('')}$, 1) = F_hlld(1) ! TODO multi-component + ! Momentum + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(1)) = F_hlld(2) + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(2)) = F_hlld(3) + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(3)) = F_hlld(4) + ! Magnetic field + if (n == 0) then + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg) = F_hlld(5) + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) = F_hlld(6) + else + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(1) - 1) = 0._wp + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(2) - 1) = F_hlld(5) + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(3) - 1) = F_hlld(6) + end if + ! Energy + flux_rsx_vf(${SF('')}$, eqn_idx%E) = F_hlld(7) + ! Volume fractions + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = 0._wp ! TODO multi-component (zero for now) + end do + + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + #:endfor + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + + end subroutine s_hlld_riemann_solver + +end module m_riemann_solver_hlld diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 4fecec51d3..4125f6ab96 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -22,6 +22,7 @@ module m_riemann_solvers use m_surface_tension use m_helper_basic use m_riemann_state + use m_riemann_solver_hlld use m_chemistry use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & & get_mixture_energy_mass, get_species_specific_heats_r, get_species_enthalpies_rt, get_mixture_specific_heat_cp_mass @@ -3240,261 +3241,6 @@ contains end subroutine s_hllc_riemann_solver - !> HLLD Riemann solver for MHD, Miyoshi & Kusano JCP (2005) - subroutine s_hlld_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & - & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf - - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - ! Local variables: - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R - #:else - real(wp), dimension(num_fluids) :: alpha_L, alpha_R, alpha_rho_L, alpha_rho_R - #:endif - type(riemann_states_vec3) :: vel - type(riemann_states) :: rho, pres, E, H_no_mag - type(riemann_states) :: gamma, pi_inf, qv - type(riemann_states) :: vel_rms - type(riemann_states_vec3) :: B - type(riemann_states) :: c, c_fast, pres_mag - - ! HLLD speeds and intermediate state variables: - real(wp) :: s_L, s_R, s_M, s_starL, s_starR - real(wp) :: pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR - real(wp), dimension(7) :: U_L, U_R, U_starL, U_starR, U_doubleL, U_doubleR - real(wp), dimension(7) :: F_L, F_R, F_starL, F_starR, F_hlld - - ! Indices for U and F: (rho, rho*vel(1), rho*vel(2), rho*vel(3), By, Bz, E) Note: vel and B are permutated, so vel(1) is the - ! normal velocity, and x is the normal direction Note: Bx is omitted as the magnetic flux is always zero in the normal - ! direction - - real(wp) :: sqrt_rhoL_star, sqrt_rhoR_star, denom_ds, sign_Bx - real(wp) :: vL_star, vR_star, wL_star, wR_star - real(wp) :: v_double, w_double, By_double, Bz_double, E_doubleL, E_doubleR, E_double - integer :: i, j, k, l - - call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) - - call s_initialize_riemann_solver(flux_src_vf, norm_dir) - - #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & - [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & - (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & - (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] - #:set SV = STENCIL_VAR - #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) - if (norm_dir == ${NORM_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[alpha_rho_L, alpha_rho_R, vel, alpha_L, alpha_R, rho, pres, E, & - & H_no_mag, gamma, pi_inf, qv, vel_rms, B, c, c_fast, pres_mag, U_L, U_R, U_starL, U_starR, & - & U_doubleL, U_doubleR, F_L, F_R, F_starL, F_starR, F_hlld, s_L, s_R, s_M, s_starL, s_starR, & - & pTot_L, pTot_R, p_star, rhoL_star, rhoR_star, E_starL, E_starR, sqrt_rhoL_star, & - & sqrt_rhoR_star, denom_ds, sign_Bx, vL_star, vR_star, wL_star, wR_star, v_double, w_double, & - & By_double, Bz_double, E_doubleL, E_doubleR, E_double]', copyin='[norm_dir]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - ! (1) Extract the left/right primitive states - do i = 1, eqn_idx%cont%end - alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) - alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - ! NOTE: unlike HLL & HLLC, vel_L here is permutated by dir_idx for simpler logic - do i = 1, num_vels - vel%L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) - vel%R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + dir_idx(i)) - end do - - vel_rms%L = sum(vel%L**2._wp) - vel_rms%R = sum(vel%R**2._wp) - - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - pres%L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres%R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - ! NOTE: unlike HLL, Bx, By, Bz are permutated by dir_idx for simpler logic - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables; only in x so not permutated - B%L = [Bx0, qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg), qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + 1)] - B%R = [Bx0, qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg), qR_prim_rsx_vf(${SF(' + 1')}$, & - & eqn_idx%B%beg + 1)] - else ! 2D/3D: Bx, By, Bz as variables - B%L = [qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(1) - 1), qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + dir_idx(2) - 1), qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + dir_idx(3) - 1)] - B%R = [qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(1) - 1), & - & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(2) - 1), & - & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + dir_idx(3) - 1)] - end if - end if - - ! Sum properties of all fluid components - rho%L = 0._wp; gamma%L = 0._wp; pi_inf%L = 0._wp; qv%L = 0._wp - rho%R = 0._wp; gamma%R = 0._wp; pi_inf%R = 0._wp; qv%R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho%L = rho%L + alpha_rho_L(i) - gamma%L = gamma%L + alpha_L(i)*gammas(i) - pi_inf%L = pi_inf%L + alpha_L(i)*pi_infs(i) - qv%L = qv%L + alpha_rho_L(i)*qvs(i) - - rho%R = rho%R + alpha_rho_R(i) - gamma%R = gamma%R + alpha_R(i)*gammas(i) - pi_inf%R = pi_inf%R + alpha_R(i)*pi_infs(i) - qv%R = qv%R + alpha_rho_R(i)*qvs(i) - end do - - pres_mag%L = 0.5_wp*sum(B%L**2._wp) - pres_mag%R = 0.5_wp*sum(B%R**2._wp) - E%L = gamma%L*pres%L + pi_inf%L + 0.5_wp*rho%L*vel_rms%L + qv%L + pres_mag%L - E%R = gamma%R*pres%R + pi_inf%R + 0.5_wp*rho%R*vel_rms%R + qv%R + pres_mag%R ! includes magnetic energy - H_no_mag%L = (E%L + pres%L - pres_mag%L)/rho%L - ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - H_no_mag%R = (E%R + pres%R - pres_mag%R)/rho%R - - ! (2) Compute fast wave speeds - call s_compute_speed_of_sound(pres%L, rho%L, gamma%L, pi_inf%L, H_no_mag%L, alpha_L, vel_rms%L, & - & 0._wp, c%L, qv%L) - call s_compute_speed_of_sound(pres%R, rho%R, gamma%R, pi_inf%R, H_no_mag%R, alpha_R, vel_rms%R, & - & 0._wp, c%R, qv%R) - call s_compute_fast_magnetosonic_speed(rho%L, c%L, B%L, norm_dir, c_fast%L, H_no_mag%L) - call s_compute_fast_magnetosonic_speed(rho%R, c%R, B%R, norm_dir, c_fast%R, H_no_mag%R) - - ! (3) Compute contact speed s_M [Miyoshi Equ. (38)] - s_L = min(vel%L(1) - c_fast%L, vel%R(1) - c_fast%R) - s_R = max(vel%R(1) + c_fast%R, vel%L(1) + c_fast%L) - - pTot_L = pres%L + pres_mag%L - pTot_R = pres%R + pres_mag%R - - s_M = (((s_R - vel%R(1))*rho%R*vel%R(1) - (s_L - vel%L(1))*rho%L*vel%L(1) - pTot_R + pTot_L)/((s_R & - & - vel%R(1))*rho%R - (s_L - vel%L(1))*rho%L)) - - ! (4) Compute star state variables - rhoL_star = rho%L*(s_L - vel%L(1))/(s_L - s_M) - rhoR_star = rho%R*(s_R - vel%R(1))/(s_R - s_M) - p_star = pTot_L + rho%L*(s_L - vel%L(1))*(s_M - vel%L(1))/(s_L - s_M) - E_starL = ((s_L - vel%L(1))*E%L - pTot_L*vel%L(1) + p_star*s_M)/(s_L - s_M) - E_starR = ((s_R - vel%R(1))*E%R - pTot_R*vel%R(1) + p_star*s_M)/(s_R - s_M) - - ! (5) Compute left/right state vectors and fluxes - U_L = [rho%L, rho%L*vel%L(1:3), B%L(2:3), E%L] - U_starL = [rhoL_star, rhoL_star*s_M, rhoL_star*vel%L(2:3), B%L(2:3), E_starL] - U_R = [rho%R, rho%R*vel%R(1:3), B%R(2:3), E%R] - U_starR = [rhoR_star, rhoR_star*s_M, rhoR_star*vel%R(2:3), B%R(2:3), E_starR] - - ! Compute the left/right fluxes - F_L(1) = U_L(2) - F_L(2) = U_L(2)*vel%L(1) - B%L(1)*B%L(1) + pTot_L - F_L(3:4) = U_L(2)*vel%L(2:3) - B%L(1)*B%L(2:3) - F_L(5:6) = vel%L(1)*B%L(2:3) - vel%L(2:3)*B%L(1) - F_L(7) = (E%L + pTot_L)*vel%L(1) - B%L(1)*(vel%L(1)*B%L(1) + vel%L(2)*B%L(2) + vel%L(3)*B%L(3)) - - F_R(1) = U_R(2) - F_R(2) = U_R(2)*vel%R(1) - B%R(1)*B%R(1) + pTot_R - F_R(3:4) = U_R(2)*vel%R(2:3) - B%R(1)*B%R(2:3) - F_R(5:6) = vel%R(1)*B%R(2:3) - vel%R(2:3)*B%R(1) - F_R(7) = (E%R + pTot_R)*vel%R(1) - B%R(1)*(vel%R(1)*B%R(1) + vel%R(2)*B%R(2) + vel%R(3)*B%R(3)) - ! HLLD star-state fluxes via HLL jump relation - F_starL = F_L + s_L*(U_starL - U_L) - F_starR = F_R + s_R*(U_starR - U_R) - ! Alfven wave speeds bounding the rotational discontinuities - s_starL = s_M - abs(B%L(1))/sqrt(rhoL_star) - s_starR = s_M + abs(B%L(1))/sqrt(rhoR_star) - ! HLLD double-star (intermediate) states across rotational discontinuities - sqrt_rhoL_star = sqrt(rhoL_star); sqrt_rhoR_star = sqrt(rhoR_star) - vL_star = vel%L(2); wL_star = vel%L(3) - vR_star = vel%R(2); wR_star = vel%R(3) - - ! (6) Compute the double-star states [Miyoshi Eqns. (59)-(62)] - denom_ds = sqrt_rhoL_star + sqrt_rhoR_star - sign_Bx = sign(1._wp, B%L(1)) - v_double = (sqrt_rhoL_star*vL_star + sqrt_rhoR_star*vR_star + (B%R(2) - B%L(2))*sign_Bx)/denom_ds - w_double = (sqrt_rhoL_star*wL_star + sqrt_rhoR_star*wR_star + (B%R(3) - B%L(3))*sign_Bx)/denom_ds - By_double = (sqrt_rhoL_star*B%R(2) + sqrt_rhoR_star*B%L(2) + sqrt_rhoL_star*sqrt_rhoR_star*(vR_star & - & - vL_star)*sign_Bx)/denom_ds - Bz_double = (sqrt_rhoL_star*B%R(3) + sqrt_rhoR_star*B%L(3) + sqrt_rhoL_star*sqrt_rhoR_star*(wR_star & - & - wL_star)*sign_Bx)/denom_ds - - E_doubleL = E_starL - sqrt_rhoL_star*((vL_star*B%L(2) + wL_star*B%L(3)) - (v_double*By_double & - & + w_double*Bz_double))*sign_Bx - E_doubleR = E_starR + sqrt_rhoR_star*((vR_star*B%R(2) + wR_star*B%R(3)) - (v_double*By_double & - & + w_double*Bz_double))*sign_Bx - E_double = 0.5_wp*(E_doubleL + E_doubleR) - - U_doubleL = [rhoL_star, rhoL_star*s_M, rhoL_star*v_double, rhoL_star*w_double, By_double, Bz_double, & - & E_double] - U_doubleR = [rhoR_star, rhoR_star*s_M, rhoR_star*v_double, rhoR_star*w_double, By_double, Bz_double, & - & E_double] - - ! Select HLLD flux region - if (0.0_wp <= s_L) then - F_hlld = F_L - else if (0.0_wp <= s_starL) then - F_hlld = F_L + s_L*(U_starL - U_L) - else if (0.0_wp <= s_M) then - F_hlld = F_starL + s_starL*(U_doubleL - U_starL) - else if (0.0_wp <= s_starR) then - F_hlld = F_starR + s_starR*(U_doubleR - U_starR) - else if (0.0_wp <= s_R) then - F_hlld = F_R + s_R*(U_starR - U_R) - else - F_hlld = F_R - end if - - ! (12) Write HLLD flux to output arrays - flux_rsx_vf(${SF('')}$, 1) = F_hlld(1) ! TODO multi-component - ! Momentum - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(1)) = F_hlld(2) - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(2)) = F_hlld(3) - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(3)) = F_hlld(4) - ! Magnetic field - if (n == 0) then - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg) = F_hlld(5) - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) = F_hlld(6) - else - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(1) - 1) = 0._wp - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(2) - 1) = F_hlld(5) - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + dir_idx(3) - 1) = F_hlld(6) - end if - ! Energy - flux_rsx_vf(${SF('')}$, eqn_idx%E) = F_hlld(7) - ! Volume fractions - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = 0._wp ! TODO multi-component (zero for now) - end do - - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - #:endfor - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) - - end subroutine s_hlld_riemann_solver - !> Initialize the Riemann solvers module impure subroutine s_initialize_riemann_solvers_module From 544959214e3dde761d590fb977badabe114253ae Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:22:19 -0400 Subject: [PATCH 07/11] src: split s_hll_riemann_solver into m_riemann_solver_hll NFC, pure motion. State access stays host-associated via m_riemann_state; the inline_riemann include moves with the solver since its macros expand here (roe_avg pulls in get_species_enthalpies_rt, gas_constant, molecular_weights, hence the m_thermochem only-list). Core re-exports the entry point through its existing public list. Statement-multiset union vs the pre-split file differs only by module boilerplate; GPU-directive census md5 unchanged; declare-target scoping verified for all files. --- docs/module_categories.json | 1 + src/simulation/m_riemann_solver_hll.fpp | 708 ++++++++++++++++++++++++ src/simulation/m_riemann_solvers.fpp | 682 +---------------------- 3 files changed, 710 insertions(+), 681 deletions(-) create mode 100644 src/simulation/m_riemann_solver_hll.fpp diff --git a/docs/module_categories.json b/docs/module_categories.json index 50b3579398..951835f796 100644 --- a/docs/module_categories.json +++ b/docs/module_categories.json @@ -8,6 +8,7 @@ "m_riemann_solvers", "m_riemann_state", "m_riemann_solver_hlld", + "m_riemann_solver_hll", "m_muscl", "m_variables_conversion", "m_thinc" diff --git a/src/simulation/m_riemann_solver_hll.fpp b/src/simulation/m_riemann_solver_hll.fpp new file mode 100644 index 0000000000..e235a1c0e4 --- /dev/null +++ b/src/simulation/m_riemann_solver_hll.fpp @@ -0,0 +1,708 @@ +!> +!! @file +!! @brief Contains module m_riemann_solver_hll + +!> @brief HLL approximate Riemann solver, Harten et al. SIAM Review (1983) +#:include 'case.fpp' +#:include 'macros.fpp' +#:include 'inline_riemann.fpp' + +module m_riemann_solver_hll + + use m_derived_types + use m_global_parameters + use m_variables_conversion + use m_constants, only: riemann_solver_hll, riemann_solver_hllc, riemann_solver_lax_friedrichs, avg_state_roe, & + & avg_state_arithmetic, wave_speeds_direct, wave_speeds_pressure + use m_chemistry + use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & + & get_mixture_energy_mass, get_species_specific_heats_r, get_species_enthalpies_rt, get_mixture_specific_heat_cp_mass, & + & molecular_weights + use m_riemann_state + + implicit none + +contains + + !> HLL approximate Riemann solver, Harten et al. SIAM Review (1983) + subroutine s_hll_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & + & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + real(wp) :: flux_tau_L, flux_tau_R + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(3) :: vel_L, vel_R + real(wp), dimension(3) :: alpha_L, alpha_R + real(wp), dimension(10) :: Ys_L, Ys_R + real(wp), dimension(10) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + #:else + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(num_vels) :: vel_L, vel_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R + real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + #:endif + real(wp) :: rho_L, rho_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi + real(wp) :: T_L, T_R + real(wp) :: Y_L, Y_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp), dimension(3) :: xi_field_L, xi_field_R + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: qv_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_M, xi_P + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum + real(wp) :: zcoef, pcorr !< low Mach number correction + type(riemann_states) :: c_fast, pres_mag + type(riemann_states_vec3) :: B + type(riemann_states) :: Ga !< Gamma (Lorentz factor) + type(riemann_states) :: vdotB, B2 + type(riemann_states_vec3) :: b4 !< 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm !< Conservative momentum variables + integer :: i, j, k, l, q !< Generic loop iterators + ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions + + call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + call s_initialize_riemann_solver(flux_src_vf, norm_dir) + #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & + [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & + (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & + (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] + #:set SV = STENCIL_VAR + #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) + if (norm_dir == ${NORM_DIR}$) then + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & + & alpha_R, tau_e_L, tau_e_R, Re_L, Re_R, s_L, s_R, s_S, Ys_L, Ys_R, xi_field_L, xi_field_R, & + & Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, c_fast, & + & pres_mag, B, Ga, vdotB, B2, b4, cm, pcorr, zcoef, vel_L_tmp, vel_R_tmp, rho_L, rho_R, & + & pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, T_L, T_R, & + & Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, Gamm_R, gamma_L, & + & gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, G_L, G_R, rho_avg, H_avg, c_avg, & + & gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, vel_avg_rms, Ms_L, Ms_R, pres_SL, & + & pres_SR, alpha_L_sum, alpha_R_sum, flux_tau_L, flux_tau_R]', copyin='[norm_dir]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) + alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables + B%L(1) = Bx0 + B%R(1) = Bx0 + B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) + B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) + B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) + B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) + else ! 2D/3D: Bx, By, Bz as variables + B%L(1) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) + B%R(1) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) + B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) + B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) + B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 2) + B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 2) + end if + end if + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + pres_mag%L = 0._wp + pres_mag%R = 0._wp + + if (mpp_lim) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) + alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) + alpha_L_sum = alpha_L_sum + alpha_L(i) + alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) + alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) + alpha_R_sum = alpha_R_sum + alpha_R(i) + end do + + alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) + alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) + Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + else if (mhd .and. relativity) then + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + b4%L(1:3) = B%L(1:3)/Ga%L + Ga%L*vel_L(1:3)*vdotB%L + b4%R(1:3) = B%R(1:3)/Ga%R + Ga%R*vel_R(1:3)*vdotB%R + B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp + B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp + #:endif + + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + cm%L(1:3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1:3) - vdotB%L*B%L(1:3) + cm%R(1:3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1:3) - vdotB%R*B%R(1:3) + #:endif + + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + else if (mhd .and. .not. relativity) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) + pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) + #:endif + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + ! includes magnetic energy + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R + H_L = (E_L + pres_L - pres_mag%L)/rho_L + ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_R = (E_R + pres_R - pres_mag%R)/rho_R + else + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! elastic energy update + if (hypoelasticity) then + G_L = 0._wp; G_R = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + + if (cont_damage) then + G_L = G_L*max((1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) + G_R = G_R*max((1._wp - qR_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + ! Elastic contribution to energy if G large enough TODO take out if statement if stable without + if ((G_L > 1000) .and. (G_R > 1000)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Double for shear stresses + if (any(eqn_idx%stress%beg - 1 + i == shear_indices)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & + & qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, c_R, & + & qv_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & + & c_sum_Yi_Phi, c_avg, qv_avg) + + if (mhd) then + call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) + call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) + end if + + if (viscous) then + if (chemistry) then + call compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L(1), Re_R(1)) + end if + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Wave speed estimates (wave_speeds=1: direct, wave_speeds=2: pressure-based) + if (wave_speeds == wave_speeds_direct) then + if (mhd) then + ! MHD: use fast magnetosonic speed + s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) + s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) + else if (hypoelasticity) then + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & + & /rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & + & /rho_L)) + else if (hyperelasticity) then + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) + else + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + end if + + if (hyper_cleaning) then + ! Dedner GLM divergence cleaning, Dedner et al. JCP (2002) + s_L = min(s_L, -hyper_cleaning_speed) + s_R = max(s_R, hyper_cleaning_speed) + end if + + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & + & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) & + & - rho_R*(s_R - vel_R(dir_idx(1)))) + else if (wave_speeds == wave_speeds_pressure) then + pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + xi_M = (5.e-1_wp + sign(5.e-1_wp, s_L)) + (5.e-1_wp - sign(5.e-1_wp, s_L))*(5.e-1_wp + sign(5.e-1_wp, & + & s_R)) + xi_P = (5.e-1_wp - sign(5.e-1_wp, s_R)) + (5.e-1_wp - sign(5.e-1_wp, s_L))*(5.e-1_wp + sign(5.e-1_wp, & + & s_R)) + + ! HLL intercell flux: F* = (s_R*F_L - s_L*F_R + s_L*s_R*(U_R - U_L)) / (s_R - s_L) Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! Mass + if (.not. relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & + & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + end do + else if (relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M & + & - s_P) + end do + end if + + ! Momentum + if (mhd .and. (.not. relativity)) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 3 + ! Flux of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i) & + & *B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i) & + & *vel_L(norm_dir) - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) + end do + else if (mhd .and. relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 3 + ! Flux of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i) & + & /Ga%R*B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i) & + & *vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L) & + & ) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + end do + else if (bubbles_euler) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + else if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L & + & - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + end do + else + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + end if + + ! Energy + if (mhd .and. (.not. relativity)) then + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir) & + & *(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) & + & + vel_L(3)*B%L(3))) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + #:endif + else if (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) + else if (bubbles_euler) then + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1) & + & )*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + else if (hypoelasticity) then + flux_tau_L = 0._wp; flux_tau_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + else + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms & + & - vel_L_rms)/2._wp + end if + + ! Elastic Stresses + if (hypoelasticity) then + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 ! TODO: this indexing may be slow + flux_rsx_vf(${SF('')}$, & + & eqn_idx%stress%beg - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) + end do + end if + + ! Advection flux and source: interface velocity for volume fraction transport + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = (qL_prim_rsx_vf(${SF('')}$, i) - qR_prim_rsx_vf(${SF(' + 1')}$, & + & i))*s_M*s_P/(s_M - s_P) + flux_src_rsx_vf(${SF('')}$, i) = (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i) - s_P*qL_prim_rsx_vf(${SF('')}$, i))/(s_M - s_P) + end do + + if (bubbles_euler) then + ! From HLLC: Kills mass transport @ bubble gas density + if (num_fluids > 1) then + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp + end if + end if + + if (chemistry) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Y_L = qL_prim_rsx_vf(${SF('')}$, i) + Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) + + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + flux_src_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + + ! MHD: magnetic flux and Maxwell stress contributions + if (mhd) then + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 + $:GPU_LOOP(parallelism='[seq]') + do i = 0, 1 + flux_rsx_vf(j, k, l, & + & eqn_idx%B%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) + end do + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y + ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ + ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + $:GPU_LOOP(parallelism='[seq]') + do i = 0, 2 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + i) = (s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1) & + & *B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1) & + & *B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + end do + + if (hyper_cleaning) then + ! propagate magnetic field divergence as a wave + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + norm_dir - 1) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + norm_dir - 1) + (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & + & eqn_idx%psi) - s_P*qL_prim_rsx_vf(${SF('')}$, eqn_idx%psi))/(s_M - s_P) + + flux_rsx_vf(${SF('')}$, & + & eqn_idx%psi) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) & + & - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%psi) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%psi)))/(s_M - s_P) + else + ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero + flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + norm_dir - 1) = 0._wp + end if + end if + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp + end if + + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + end if + + if (cyl_coord .and. hypoelasticity) then + ! += tau_sigmasigma using HLL + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%stress%beg, eqn_idx%stress%end + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + #:endfor + + if (viscous) then + if (weno_Re_flux) then + call s_compute_viscous_source_flux(qL_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & qR_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & + & norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux(q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & + & norm_dir, ix, iy, iz) + end if + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + + end subroutine s_hll_riemann_solver + +end module m_riemann_solver_hll diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 4125f6ab96..b170419511 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -22,6 +22,7 @@ module m_riemann_solvers use m_surface_tension use m_helper_basic use m_riemann_state + use m_riemann_solver_hll use m_riemann_solver_hlld use m_chemistry use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & @@ -61,687 +62,6 @@ contains end subroutine s_riemann_solver - !> HLL approximate Riemann solver, Harten et al. SIAM Review (1983) - subroutine s_hll_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & - & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L, flux_tau_R - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(3) :: vel_L, vel_R - real(wp), dimension(3) :: alpha_L, alpha_R - real(wp), dimension(10) :: Ys_L, Ys_R - real(wp), dimension(10) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - #:else - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(num_vels) :: vel_L, vel_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R - real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - #:endif - real(wp) :: rho_L, rho_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi - real(wp) :: T_L, T_R - real(wp) :: Y_L, Y_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp) :: G_L, G_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp), dimension(3) :: xi_field_L, xi_field_R - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: qv_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_M, xi_P - real(wp) :: ptilde_L, ptilde_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR - real(wp) :: alpha_L_sum, alpha_R_sum - real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag - type(riemann_states_vec3) :: B - type(riemann_states) :: Ga !< Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 !< 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm !< Conservative momentum variables - integer :: i, j, k, l, q !< Generic loop iterators - ! Populating the buffers of the left and right Riemann problem states variables, based on the choice of boundary conditions - - call s_populate_riemann_states_variables_buffers(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - call s_initialize_riemann_solver(flux_src_vf, norm_dir) - #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & - [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & - (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & - (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] - #:set SV = STENCIL_VAR - #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) - if (norm_dir == ${NORM_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & - & alpha_R, tau_e_L, tau_e_R, Re_L, Re_R, s_L, s_R, s_S, Ys_L, Ys_R, xi_field_L, xi_field_R, & - & Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, c_fast, & - & pres_mag, B, Ga, vdotB, B2, b4, cm, pcorr, zcoef, vel_L_tmp, vel_R_tmp, rho_L, rho_R, & - & pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, T_L, T_R, & - & Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, Gamm_R, gamma_L, & - & gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, G_L, G_R, rho_avg, H_avg, c_avg, & - & gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, vel_avg_rms, Ms_L, Ms_R, pres_SL, & - & pres_SR, alpha_L_sum, alpha_R_sum, flux_tau_L, flux_tau_R]', copyin='[norm_dir]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) - alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) - B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) - B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) - B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) - B%R(1) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) - B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) - B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) - B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 2) - B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 2) - end if - end if - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - pres_mag%L = 0._wp - pres_mag%R = 0._wp - - if (mpp_lim) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) - alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) - alpha_L_sum = alpha_L_sum + alpha_L(i) - alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) - alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) - alpha_R_sum = alpha_R_sum + alpha_R(i) - end do - - alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) - alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) - Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - else if (mhd .and. relativity) then - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1:3) = B%L(1:3)/Ga%L + Ga%L*vel_L(1:3)*vdotB%L - b4%R(1:3) = B%R(1:3)/Ga%R + Ga%R*vel_R(1:3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - #:endif - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - cm%L(1:3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1:3) - vdotB%L*B%L(1:3) - cm%R(1:3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1:3) - vdotB%R*B%R(1:3) - #:endif - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - else if (mhd .and. .not. relativity) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - #:endif - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - ! includes magnetic energy - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R - H_L = (E_L + pres_L - pres_mag%L)/rho_L - ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - H_R = (E_R + pres_R - pres_mag%R)/rho_R - else - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! elastic energy update - if (hypoelasticity) then - G_L = 0._wp; G_R = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - - if (cont_damage) then - G_L = G_L*max((1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) - G_R = G_R*max((1._wp - qR_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - ! Elastic contribution to energy if G large enough TODO take out if statement if stable without - if ((G_L > 1000) .and. (G_R > 1000)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Double for shear stresses - if (any(eqn_idx%stress%beg - 1 + i == shear_indices)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & - & qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, c_R, & - & qv_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & - & c_sum_Yi_Phi, c_avg, qv_avg) - - if (mhd) then - call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) - call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) - end if - - if (viscous) then - if (chemistry) then - call compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L(1), Re_R(1)) - end if - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Wave speed estimates (wave_speeds=1: direct, wave_speeds=2: pressure-based) - if (wave_speeds == wave_speeds_direct) then - if (mhd) then - ! MHD: use fast magnetosonic speed - s_L = min(vel_L(dir_idx(1)) - c_fast%L, vel_R(dir_idx(1)) - c_fast%R) - s_R = max(vel_R(dir_idx(1)) + c_fast%R, vel_L(dir_idx(1)) + c_fast%L) - else if (hypoelasticity) then - ! Elastic wave speed, Rodriguez et al. JCP (2019) - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & - & /rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & - & /rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1))) & - & /rho_R), & - & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1))) & - & /rho_L)) - else if (hyperelasticity) then - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (4._wp*G_R/3._wp)/rho_R), & - & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (4._wp*G_L/3._wp)/rho_L)) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - end if - - if (hyper_cleaning) then - ! Dedner GLM divergence cleaning, Dedner et al. JCP (2002) - s_L = min(s_L, -hyper_cleaning_speed) - s_R = max(s_R, hyper_cleaning_speed) - end if - - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L - vel_L(dir_idx(1))) & - & - rho_R*(s_R - vel_R(dir_idx(1)))) - else if (wave_speeds == wave_speeds_pressure) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - ! Low Mach correction: Thornber et al. JCP (2008) - Ms_L = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & - & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & - & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - xi_M = (5.e-1_wp + sign(5.e-1_wp, s_L)) + (5.e-1_wp - sign(5.e-1_wp, s_L))*(5.e-1_wp + sign(5.e-1_wp, & - & s_R)) - xi_P = (5.e-1_wp - sign(5.e-1_wp, s_R)) + (5.e-1_wp - sign(5.e-1_wp, s_L))*(5.e-1_wp + sign(5.e-1_wp, & - & s_R)) - - ! HLL intercell flux: F* = (s_R*F_L - s_L*F_R + s_L*s_R*(U_R - U_L)) / (s_R - s_L) Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! Mass - if (.not. relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) - end do - else if (relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M & - & - s_P) - end do - end if - - ! Momentum - if (mhd .and. (.not. relativity)) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 3 - ! Flux of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + - ! delta_(${XYZ}$,i) * p_tot - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i) & - & *B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i) & - & *vel_L(norm_dir) - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) - end do - else if (mhd .and. relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 3 - ! Flux of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + - ! delta_(${XYZ}$,i) * p_tot - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i) & - & /Ga%R*B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i) & - & *vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L) & - & ) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) - end do - else if (bubbles_euler) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - else if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & - & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L & - & - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) - end do - else - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - end if - - ! Energy - if (mhd .and. (.not. relativity)) then - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & - & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir) & - & *(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) & - & + vel_L(3)*B%L(3))) + s_M*s_P*(E_L - E_R))/(s_M - s_P) - #:endif - else if (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R)) & - & /(s_M - s_P) - else if (bubbles_euler) then - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1) & - & )*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - flux_tau_L = 0._wp; flux_tau_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) - flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) - end do - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M & - & - s_P) - else - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms & - & - vel_L_rms)/2._wp - end if - - ! Elastic Stresses - if (hypoelasticity) then - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 ! TODO: this indexing may be slow - flux_rsx_vf(${SF('')}$, & - & eqn_idx%stress%beg - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & - & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & - & - rho_R*tau_e_R(i)))/(s_M - s_P) - end do - end if - - ! Advection flux and source: interface velocity for volume fraction transport - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = (qL_prim_rsx_vf(${SF('')}$, i) - qR_prim_rsx_vf(${SF(' + 1')}$, & - & i))*s_M*s_P/(s_M - s_P) - flux_src_rsx_vf(${SF('')}$, i) = (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i) - s_P*qL_prim_rsx_vf(${SF('')}$, i))/(s_M - s_P) - end do - - if (bubbles_euler) then - ! From HLLC: Kills mass transport @ bubble gas density - if (num_fluids > 1) then - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp - end if - end if - - if (chemistry) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Y_L = qL_prim_rsx_vf(${SF('')}$, i) - Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) - - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) - flux_src_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - - ! MHD: magnetic flux and Maxwell stress contributions - if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 - $:GPU_LOOP(parallelism='[seq]') - do i = 0, 1 - flux_rsx_vf(j, k, l, & - & eqn_idx%B%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & - & - B%R(2 + i)))/(s_M - s_P) - end do - else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y - ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ - ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - $:GPU_LOOP(parallelism='[seq]') - do i = 0, 2 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + i) = (s_M*(vel_R(dir_idx(1))*B%R(i + 1) - vel_R(i + 1) & - & *B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i + 1) & - & *B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) - end do - - if (hyper_cleaning) then - ! propagate magnetic field divergence as a wave - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + norm_dir - 1) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + norm_dir - 1) + (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & - & eqn_idx%psi) - s_P*qL_prim_rsx_vf(${SF('')}$, eqn_idx%psi))/(s_M - s_P) - - flux_rsx_vf(${SF('')}$, & - & eqn_idx%psi) = (hyper_cleaning_speed**2*(s_M*B%R(norm_dir) & - & - s_P*B%L(norm_dir)) + s_M*s_P*(qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%psi) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%psi)))/(s_M - s_P) - else - ! Without hyperbolic cleaning, make sure flux of B_normal is identically zero - flux_rsx_vf(${SF('')}$, eqn_idx%B%beg + norm_dir - 1) = 0._wp - end if - end if - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp - end if - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - end if - - if (cyl_coord .and. hypoelasticity) then - ! += tau_sigmasigma using HLL - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) - - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%stress%beg, eqn_idx%stress%end - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - #:endfor - - if (viscous) then - if (weno_Re_flux) then - call s_compute_viscous_source_flux(qL_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & qR_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & - & norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux(q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & - & norm_dir, ix, iy, iz) - end if - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) - - end subroutine s_hll_riemann_solver - !> Lax-Friedrichs (Rusanov) approximate Riemann solver subroutine s_lf_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & From 6bf435552468365d84c3ca5d18466fe63db75e59 Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:26:39 -0400 Subject: [PATCH 08/11] src: split s_lf_riemann_solver into m_riemann_solver_lf NFC, pure motion. State access stays host-associated via m_riemann_state; inline_riemann macros expand here (low-Mach correction), and the solver references molecular_weights directly, hence the m_thermochem only-list. Core re-exports the entry point through its existing public list. Statement-multiset union vs the pre-split file differs only by module boilerplate; GPU-directive census md5 unchanged; declare-target scoping verified for all files. --- docs/module_categories.json | 1 + src/simulation/m_riemann_solver_lf.fpp | 891 +++++++++++++++++++++++++ src/simulation/m_riemann_solvers.fpp | 868 +----------------------- 3 files changed, 893 insertions(+), 867 deletions(-) create mode 100644 src/simulation/m_riemann_solver_lf.fpp diff --git a/docs/module_categories.json b/docs/module_categories.json index 951835f796..ebba674ba4 100644 --- a/docs/module_categories.json +++ b/docs/module_categories.json @@ -9,6 +9,7 @@ "m_riemann_state", "m_riemann_solver_hlld", "m_riemann_solver_hll", + "m_riemann_solver_lf", "m_muscl", "m_variables_conversion", "m_thinc" diff --git a/src/simulation/m_riemann_solver_lf.fpp b/src/simulation/m_riemann_solver_lf.fpp new file mode 100644 index 0000000000..c3c3aaa959 --- /dev/null +++ b/src/simulation/m_riemann_solver_lf.fpp @@ -0,0 +1,891 @@ +!> +!! @file +!! @brief Contains module m_riemann_solver_lf + +!> @brief Lax-Friedrichs (Rusanov) approximate Riemann solver +#:include 'case.fpp' +#:include 'macros.fpp' +#:include 'inline_riemann.fpp' + +module m_riemann_solver_lf + + use m_derived_types + use m_global_parameters + use m_variables_conversion + use m_constants, only: riemann_solver_hll, riemann_solver_hllc, riemann_solver_lax_friedrichs + use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & + & get_mixture_energy_mass, get_species_specific_heats_r, get_mixture_specific_heat_cp_mass, molecular_weights + use m_riemann_state + + implicit none + +contains + + !> Lax-Friedrichs (Rusanov) approximate Riemann solver + subroutine s_lf_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & + & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + real(wp) :: flux_tau_L, flux_tau_R + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(3) :: vel_L, vel_R + real(wp), dimension(3) :: alpha_L, alpha_R + real(wp), dimension(10) :: Ys_L, Ys_R + real(wp), dimension(10) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + real(wp), dimension(3, 3) :: vel_grad_L, vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + #:else + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(num_vels) :: vel_L, vel_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_species) :: Ys_L, Ys_R + real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + !> Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. + real(wp), dimension(num_dims, num_dims) :: vel_grad_L, vel_grad_R + #:endif + real(wp) :: rho_L, rho_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi + real(wp) :: T_L, T_R + real(wp) :: Y_L, Y_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(6) :: tau_e_L, tau_e_R + real(wp) :: G_L, G_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp), dimension(3) :: xi_field_L, xi_field_R + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: c_avg + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_M, xi_P + real(wp) :: ptilde_L, ptilde_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR + real(wp) :: alpha_L_sum, alpha_R_sum + real(wp) :: zcoef, pcorr !< low Mach number correction + type(riemann_states) :: c_fast, pres_mag + type(riemann_states_vec3) :: B + type(riemann_states) :: Ga !< Gamma (Lorentz factor) + type(riemann_states) :: vdotB, B2 + type(riemann_states_vec3) :: b4 !< 4-magnetic field components (spatial: b4x, b4y, b4z) + type(riemann_states_vec3) :: cm !< Conservative momentum variables + integer :: i, j, k, l, q !< Generic loop iterators + integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. + ! 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, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + call s_initialize_riemann_solver(flux_src_vf, norm_dir) + #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & + [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & + (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & + (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] + #:set SV = STENCIL_VAR + #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) + if (norm_dir == ${NORM_DIR}$) then + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & + & alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, & + & Ys_L, Ys_R, xi_field_L, xi_field_R, Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Yi_avg, & + & Phi_avg, h_iL, h_iR, h_avg_2, c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, pcorr, zcoef, & + & vel_grad_L, vel_grad_R, idx_right_phys, vel_L_rms, vel_R_rms, vel_avg_rms, vel_L_tmp, & + & vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, alpha_R_sum, c_avg, pres_L, pres_R, & + & rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, c_L, c_R, E_L, E_R, H_L, & + & H_R, ptilde_L, ptilde_R, s_M, s_P, xi_M, xi_P, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, & + & Cp_L, Cp_R, Cv_L, Cv_R, R_gas_L, R_gas_R, MW_L, MW_R, T_L, T_R, Y_L, Y_R]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) + alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + if (mhd) then + if (n == 0) then ! 1D: constant Bx; By, Bz as variables + B%L(1) = Bx0 + B%R(1) = Bx0 + B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) + B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) + B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) + B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) + else ! 2D/3D: Bx, By, Bz as variables + B%L(1) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) + B%R(1) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) + B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) + B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) + B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 2) + B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 2) + end if + end if + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + pres_mag%L = 0._wp + pres_mag%R = 0._wp + + if (mpp_lim) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) + alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) + alpha_L_sum = alpha_L_sum + alpha_L(i) + alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) + alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) + alpha_R_sum = alpha_R_sum + alpha_R(i) + end do + + alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) + alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) + Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) + Gamm_R = Cp_R/Cv_R + gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + else if (mhd .and. relativity) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) + Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) + vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) + vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) + + b4%L(1:3) = B%L(1:3)/Ga%L + Ga%L*vel_L(1:3)*vdotB%L + b4%R(1:3) = B%R(1:3)/Ga%R + Ga%R*vel_R(1:3)*vdotB%R + B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp + B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp + + pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) + pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) + + ! Hard-coded EOS + H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L + H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R + + cm%L(1:3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1:3) - vdotB%L*B%L(1:3) + cm%R(1:3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1:3) - vdotB%R*B%R(1:3) + + E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L + E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R + #:endif + else if (mhd .and. .not. relativity) then + pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) + pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) + E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L + ! includes magnetic energy + E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R + H_L = (E_L + pres_L - pres_mag%L)/rho_L + ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) + H_R = (E_R + pres_R - pres_mag%R)/rho_R + else + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! elastic energy update + if (hypoelasticity) then + G_L = 0._wp; G_R = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + + if (cont_damage) then + G_L = G_L*max((1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) + G_R = G_R*max((1._wp - qR_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) + end if + + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + ! Elastic contribution to energy if G large enough TODO take out if statement if stable without + if ((G_L > 1000) .and. (G_R > 1000)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Double for shear stresses + if (any(eqn_idx%stress%beg - 1 + i == shear_indices)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & + & qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, c_R, & + & qv_R) + + if (mhd) then + call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) + call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) + end if + + s_L = 0._wp; s_R = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + s_L = s_L + vel_L(i)**2._wp + s_R = s_R + vel_R(i)**2._wp + end do + + s_L = sqrt(s_L) + s_R = sqrt(s_R) + + s_P = max(s_L, s_R) + max(c_L, c_R) + s_M = -s_P + + s_L = s_M + s_R = s_P + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! Mass + if (.not. relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & + & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) + end do + else if (relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & + & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M & + & - s_P) + end do + end if + + ! Momentum + if (mhd .and. (.not. relativity)) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 3 + ! Flux of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i) & + & *B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i) & + & *vel_L(norm_dir) - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & + & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) + end do + else if (mhd .and. relativity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 3 + ! Flux of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + + ! delta_(${XYZ}$,i) * p_tot + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i) & + & /Ga%R*B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i) & + & *vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L) & + & ) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) + end do + else if (bubbles_euler) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & + & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & + & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & + & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + else if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & + & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L & + & - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + end do + else + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_vels + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & + & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & + & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) + end do + end if + + ! Energy + if (mhd .and. (.not. relativity)) then + ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & + & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir) & + & *(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) & + & + vel_L(3)*B%L(3))) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + #:endif + else if (mhd .and. relativity) then + ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & + & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R)) & + & /(s_M - s_P) + else if (bubbles_euler) then + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1) & + & )*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*(vel_R_rms - vel_L_rms)/2._wp + else if (hypoelasticity) then + flux_tau_L = 0._wp; flux_tau_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) + flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) + end do + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & + & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M & + & - s_P) + else + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & + & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms & + & - vel_L_rms)/2._wp + end if + + ! Elastic Stresses + if (hypoelasticity) then + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 ! TODO: this indexing may be slow + flux_rsx_vf(${SF('')}$, & + & eqn_idx%stress%beg - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & + & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & + & - rho_R*tau_e_R(i)))/(s_M - s_P) + end do + end if + + ! Advection flux and source: interface velocity for volume fraction transport + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = (qL_prim_rsx_vf(${SF('')}$, i) - qR_prim_rsx_vf(${SF(' + 1')}$, & + & i))*s_M*s_P/(s_M - s_P) + flux_src_rsx_vf(${SF('')}$, i) = (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i) - s_P*qL_prim_rsx_vf(${SF('')}$, i))/(s_M - s_P) + end do + + if (bubbles_euler) then + ! From HLLC: Kills mass transport @ bubble gas density + if (num_fluids > 1) then + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp + end if + end if + + if (chemistry) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Y_L = qL_prim_rsx_vf(${SF('')}$, i) + Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) + + flux_rsx_vf(${SF('')}$, & + & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & + & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) + flux_src_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + + ! MHD: magnetic flux and Maxwell stress contributions + if (mhd) then + if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. + ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 + $:GPU_LOOP(parallelism='[seq]') + do i = 0, 1 + flux_rsx_vf(j, k, l, & + & eqn_idx%B%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & + & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & + & - B%R(2 + i)))/(s_M - s_P) + end do + else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction + ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y + ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ + ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) + $:GPU_LOOP(parallelism='[seq]') + do i = 0, 2 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%B%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i + 1) & + & - vel_R(i + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i & + & + 1)*B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) + end do + end if + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp + end if + + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + end if + + if (cyl_coord .and. hypoelasticity) then + ! += tau_sigmasigma using HLL + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) + + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%stress%beg, eqn_idx%stress%end + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + #:endfor + + if (viscous) then + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, idx_right_phys, vel_grad_L, vel_grad_R, alpha_L, alpha_R, & + & vel_L, vel_R, Re_L, Re_R]', copyin='[norm_dir]') + do l = isz%beg, isz%end + do k = isy%beg, isy%end + do j = isx%beg, isx%end + idx_right_phys(1) = j + idx_right_phys(2) = k + idx_right_phys(3) = l + idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 + + if (norm_dir == 1) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(j + 1, k, l, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) + vel_R(i) = qR_prim_rsx_vf(j + 1, k, l, eqn_idx%mom%beg + i - 1) + end do + else if (norm_dir == 2) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(j, k + 1, l, eqn_idx%E + i) + end do + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) + vel_R(i) = qR_prim_rsx_vf(j, k + 1, l, eqn_idx%mom%beg + i - 1) + end do + else + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(j, k, l + 1, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) + vel_R(i) = qR_prim_rsx_vf(j, k, l + 1, eqn_idx%mom%beg + i - 1) + end do + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + + if (shear_stress) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_grad_L(i, 1) = (dqL_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) + vel_grad_R(i, 1) = (dqR_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + vel_grad_L(i, 2) = (dqL_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) + vel_grad_R(i, 2) = (dqR_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + end if + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + vel_grad_L(i, 3) = (dqL_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) + vel_grad_R(i, 3) = (dqR_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) + end if + #:endif + #:endif + end do + + if (norm_dir == 1) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(1)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(1) + vel_grad_R(2, & + & 2)*vel_R(1)) + + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, & + & 1) + vel_grad_R(2, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 2)*vel_L(2) + vel_grad_R(1, & + & 2)*vel_R(2)) - 0.5_wp*(vel_grad_L(2, 1)*vel_L(2) + vel_grad_R(2, 1)*vel_R(2)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, & + & 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 3) + vel_grad_R(1, & + & 3)) - 0.5_wp*(vel_grad_L(3, 1) + vel_grad_R(3, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 3)*vel_L(3) + vel_grad_R(1, & + & 3)*vel_R(3)) - 0.5_wp*(vel_grad_L(3, 1)*vel_L(3) + vel_grad_R(3, & + & 1)*vel_R(3)) + end if + #:endif + end if + #:endif + else if (norm_dir == 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) + + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(2)) + + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, & + & 1) + vel_grad_R(2, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 2)*vel_L(1) + vel_grad_R(1, & + & 2)*vel_R(1)) - 0.5_wp*(vel_grad_L(2, 1)*vel_L(1) + vel_grad_R(2, 1)*vel_R(1)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, & + & k, l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, & + & 3)*vel_R(2)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, & + & k, l) - 0.5_wp*(vel_grad_L(2, 3) + vel_grad_R(2, & + & 3)) - 0.5_wp*(vel_grad_L(3, 2) + vel_grad_R(3, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 3)*vel_L(3) + vel_grad_R(2, & + & 3)*vel_R(3)) - 0.5_wp*(vel_grad_L(3, 2)*vel_L(3) + vel_grad_R(3, & + & 2)*vel_R(3)) + end if + #:endif + #:endif + else + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) + + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 3) + vel_grad_R(1, 3)) - 0.5_wp*(vel_grad_L(3, & + & 1) + vel_grad_R(3, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 3)*vel_L(1) + vel_grad_R(1, & + & 3)*vel_R(1)) - 0.5_wp*(vel_grad_L(3, 1)*vel_L(1) + vel_grad_R(3, 1)*vel_R(1)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) + + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 3) + vel_grad_R(2, 3)) - 0.5_wp*(vel_grad_L(3, & + & 2) + vel_grad_R(3, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 3)*vel_L(2) + vel_grad_R(2, & + & 3)*vel_R(2)) - 0.5_wp*(vel_grad_L(3, 2)*vel_L(2) + vel_grad_R(3, 2)*vel_R(2)) + #:endif + end if + end if + + if (bulk_stress) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_grad_L(i, 1) = (dqL_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) + vel_grad_R(i, 1) = (dqR_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + vel_grad_L(i, 2) = (dqL_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) + vel_grad_R(i, 2) = (dqR_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + end if + #:endif + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + vel_grad_L(i, 3) = (dqL_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) + vel_grad_R(i, 3) = (dqR_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & + & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) + end if + #:endif + end do + + if (norm_dir == 1) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & + & 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(1)) + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + if (num_dims > 1) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(1) + vel_grad_R(2, 2)*vel_R(1)) + + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) + end if + #:endif + end if + #:endif + else if (norm_dir == 2) then + #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) + + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(2)) + + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + if (num_dims > 2) then + flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, & + & k, l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, 3)*vel_R(2)) + end if + #:endif + #:endif + else + #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(1, 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) + + flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) + flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & + & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) + #:endif + end if + end if + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + + end subroutine s_lf_riemann_solver + +end module m_riemann_solver_lf diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index b170419511..6bbc938ecd 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -22,6 +22,7 @@ module m_riemann_solvers use m_surface_tension use m_helper_basic use m_riemann_state + use m_riemann_solver_lf use m_riemann_solver_hll use m_riemann_solver_hlld use m_chemistry @@ -62,873 +63,6 @@ contains end subroutine s_riemann_solver - !> Lax-Friedrichs (Rusanov) approximate Riemann solver - subroutine s_lf_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & - & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - real(wp) :: flux_tau_L, flux_tau_R - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(3) :: vel_L, vel_R - real(wp), dimension(3) :: alpha_L, alpha_R - real(wp), dimension(10) :: Ys_L, Ys_R - real(wp), dimension(10) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - real(wp), dimension(3, 3) :: vel_grad_L, vel_grad_R !< Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - #:else - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(num_vels) :: vel_L, vel_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_species) :: Ys_L, Ys_R - real(wp), dimension(num_species) :: Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - !> Averaged velocity gradient tensor `d(vel_i)/d(coord_j)`. - real(wp), dimension(num_dims, num_dims) :: vel_grad_L, vel_grad_R - #:endif - real(wp) :: rho_L, rho_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - real(wp) :: Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi - real(wp) :: T_L, T_R - real(wp) :: Y_L, Y_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(6) :: tau_e_L, tau_e_R - real(wp) :: G_L, G_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp), dimension(3) :: xi_field_L, xi_field_R - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: c_avg - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_M, xi_P - real(wp) :: ptilde_L, ptilde_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: Ms_L, Ms_R, pres_SL, pres_SR - real(wp) :: alpha_L_sum, alpha_R_sum - real(wp) :: zcoef, pcorr !< low Mach number correction - type(riemann_states) :: c_fast, pres_mag - type(riemann_states_vec3) :: B - type(riemann_states) :: Ga !< Gamma (Lorentz factor) - type(riemann_states) :: vdotB, B2 - type(riemann_states_vec3) :: b4 !< 4-magnetic field components (spatial: b4x, b4y, b4z) - type(riemann_states_vec3) :: cm !< Conservative momentum variables - integer :: i, j, k, l, q !< Generic loop iterators - integer, dimension(3) :: idx_right_phys !< Physical (j,k,l) indices for right state. - ! 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, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - call s_initialize_riemann_solver(flux_src_vf, norm_dir) - #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & - [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & - (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & - (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] - #:set SV = STENCIL_VAR - #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) - if (norm_dir == ${NORM_DIR}$) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, & - & alpha_R, tau_e_L, tau_e_R, G_L, G_R, Re_L, Re_R, rho_avg, h_avg, gamma_avg, s_L, s_R, s_S, & - & Ys_L, Ys_R, xi_field_L, xi_field_R, Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Yi_avg, & - & Phi_avg, h_iL, h_iR, h_avg_2, c_fast, pres_mag, B, Ga, vdotB, B2, b4, cm, pcorr, zcoef, & - & vel_grad_L, vel_grad_R, idx_right_phys, vel_L_rms, vel_R_rms, vel_avg_rms, vel_L_tmp, & - & vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, alpha_R_sum, c_avg, pres_L, pres_R, & - & rho_L, rho_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, c_L, c_R, E_L, E_R, H_L, & - & H_R, ptilde_L, ptilde_R, s_M, s_P, xi_M, xi_P, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, & - & Cp_L, Cp_R, Cv_L, Cv_R, R_gas_L, R_gas_R, MW_L, MW_R, T_L, T_R, Y_L, Y_R]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) - alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - if (mhd) then - if (n == 0) then ! 1D: constant Bx; By, Bz as variables - B%L(1) = Bx0 - B%R(1) = Bx0 - B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) - B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) - B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) - B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) - else ! 2D/3D: Bx, By, Bz as variables - B%L(1) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg) - B%R(1) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg) - B%L(2) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 1) - B%R(2) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 1) - B%L(3) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%B%beg + 2) - B%R(3) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%B%beg + 2) - end if - end if - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - pres_mag%L = 0._wp - pres_mag%R = 0._wp - - if (mpp_lim) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_rho_L(i) = max(0._wp, alpha_rho_L(i)) - alpha_L(i) = min(max(0._wp, alpha_L(i)), 1._wp) - alpha_L_sum = alpha_L_sum + alpha_L(i) - alpha_rho_R(i) = max(0._wp, alpha_rho_R(i)) - alpha_R(i) = min(max(0._wp, alpha_R(i)), 1._wp) - alpha_R_sum = alpha_R_sum + alpha_R(i) - end do - - alpha_L = alpha_L/max(alpha_L_sum, sgm_eps) - alpha_R = alpha_R/max(alpha_R_sum, sgm_eps) - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) - Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - ! gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - ! gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp) - Gamm_R = Cp_R/Cv_R - gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - else if (mhd .and. relativity) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - Ga%L = 1._wp/sqrt(1._wp - vel_L_rms) - Ga%R = 1._wp/sqrt(1._wp - vel_R_rms) - vdotB%L = vel_L(1)*B%L(1) + vel_L(2)*B%L(2) + vel_L(3)*B%L(3) - vdotB%R = vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3) - - b4%L(1:3) = B%L(1:3)/Ga%L + Ga%L*vel_L(1:3)*vdotB%L - b4%R(1:3) = B%R(1:3)/Ga%R + Ga%R*vel_R(1:3)*vdotB%R - B2%L = B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp - B2%R = B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp - - pres_mag%L = 0.5_wp*(B2%L/Ga%L**2._wp + vdotB%L**2._wp) - pres_mag%R = 0.5_wp*(B2%R/Ga%R**2._wp + vdotB%R**2._wp) - - ! Hard-coded EOS - H_L = 1._wp + (gamma_L + 1)*pres_L/rho_L - H_R = 1._wp + (gamma_R + 1)*pres_R/rho_R - - cm%L(1:3) = (rho_L*H_L*Ga%L**2 + B2%L)*vel_L(1:3) - vdotB%L*B%L(1:3) - cm%R(1:3) = (rho_R*H_R*Ga%R**2 + B2%R)*vel_R(1:3) - vdotB%R*B%R(1:3) - - E_L = rho_L*H_L*Ga%L**2 - pres_L + 0.5_wp*(B2%L + vel_L_rms*B2%L - vdotB%L**2._wp) - rho_L*Ga%L - E_R = rho_R*H_R*Ga%R**2 - pres_R + 0.5_wp*(B2%R + vel_R_rms*B2%R - vdotB%R**2._wp) - rho_R*Ga%R - #:endif - else if (mhd .and. .not. relativity) then - pres_mag%L = 0.5_wp*(B%L(1)**2._wp + B%L(2)**2._wp + B%L(3)**2._wp) - pres_mag%R = 0.5_wp*(B%R(1)**2._wp + B%R(2)**2._wp + B%R(3)**2._wp) - E_L = gamma_L*pres_L + pi_inf_L + 0.5_wp*rho_L*vel_L_rms + qv_L + pres_mag%L - ! includes magnetic energy - E_R = gamma_R*pres_R + pi_inf_R + 0.5_wp*rho_R*vel_R_rms + qv_R + pres_mag%R - H_L = (E_L + pres_L - pres_mag%L)/rho_L - ! stagnation enthalpy here excludes magnetic energy (only used to find speed of sound) - H_R = (E_R + pres_R - pres_mag%R)/rho_R - else - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! elastic energy update - if (hypoelasticity) then - G_L = 0._wp; G_R = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - - if (cont_damage) then - G_L = G_L*max((1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) - G_R = G_R*max((1._wp - qR_prim_rsx_vf(${SF('')}$, eqn_idx%damage)), 0._wp) - end if - - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - ! Elastic contribution to energy if G large enough TODO take out if statement if stable without - if ((G_L > 1000) .and. (G_R > 1000)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Double for shear stresses - if (any(eqn_idx%stress%beg - 1 + i == shear_indices)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, c_L, & - & qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, c_R, & - & qv_R) - - if (mhd) then - call s_compute_fast_magnetosonic_speed(rho_L, c_L, B%L, norm_dir, c_fast%L, H_L) - call s_compute_fast_magnetosonic_speed(rho_R, c_R, B%R, norm_dir, c_fast%R, H_R) - end if - - s_L = 0._wp; s_R = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - s_L = s_L + vel_L(i)**2._wp - s_R = s_R + vel_R(i)**2._wp - end do - - s_L = sqrt(s_L) - s_R = sqrt(s_R) - - s_P = max(s_L, s_R) + max(c_L, c_R) - s_M = -s_P - - s_L = s_M - s_R = s_P - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! Mass - if (.not. relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*alpha_rho_R(i)*vel_R(norm_dir) - s_P*alpha_rho_L(i)*vel_L(norm_dir) & - & + s_M*s_P*(alpha_rho_L(i) - alpha_rho_R(i)))/(s_M - s_P) - end do - else if (relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*Ga%R*alpha_rho_R(i)*vel_R(norm_dir) - s_P*Ga%L*alpha_rho_L(i) & - & *vel_L(norm_dir) + s_M*s_P*(Ga%L*alpha_rho_L(i) - Ga%R*alpha_rho_R(i)))/(s_M & - & - s_P) - end do - end if - - ! Momentum - if (mhd .and. (.not. relativity)) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 3 - ! Flux of rho*v_i in the ${XYZ}$ direction = rho * v_i * v_${XYZ}$ - B_i * B_${XYZ}$ + - ! delta_(${XYZ}$,i) * p_tot - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + i) = (s_M*(rho_R*vel_R(i)*vel_R(norm_dir) - B%R(i) & - & *B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(rho_L*vel_L(i) & - & *vel_L(norm_dir) - B%L(i)*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L)) & - & + s_M*s_P*(rho_L*vel_L(i) - rho_R*vel_R(i)))/(s_M - s_P) - end do - else if (mhd .and. relativity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 3 - ! Flux of m_i in the ${XYZ}$ direction = m_i * v_${XYZ}$ - b_i/Gamma * B_${XYZ}$ + - ! delta_(${XYZ}$,i) * p_tot - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + i) = (s_M*(cm%R(i)*vel_R(norm_dir) - b4%R(i) & - & /Ga%R*B%R(norm_dir) + dir_flg(i)*(pres_R + pres_mag%R)) - s_P*(cm%L(i) & - & *vel_L(norm_dir) - b4%L(i)/Ga%L*B%L(norm_dir) + dir_flg(i)*(pres_L + pres_mag%L) & - & ) + s_M*s_P*(cm%L(i) - cm%R(i)))/(s_M - s_P) - end do - else if (bubbles_euler) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(pres_R - ptilde_R)) - s_P*(rho_L*vel_L(dir_idx(1)) & - & *vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*(pres_L - ptilde_L)) & - & + s_M*s_P*(rho_L*vel_L(dir_idx(i)) - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) & - & + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - else if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R - tau_e_R(dir_idx_tau(i))) & - & - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*pres_L & - & - tau_e_L(dir_idx_tau(i))) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) - end do - else - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_vels - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = (s_M*(rho_R*vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_R) - s_P*(rho_L*vel_L(dir_idx(1))*vel_L(dir_idx(i)) & - & + dir_flg(dir_idx(i))*pres_L) + s_M*s_P*(rho_L*vel_L(dir_idx(i)) & - & - rho_R*vel_R(dir_idx(i))))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R(dir_idx(i)) - vel_L(dir_idx(i))) - end do - end if - - ! Energy - if (mhd .and. (.not. relativity)) then - ! energy flux = (E + p + p_mag) * v_${XYZ}$ - B_${XYZ}$ * (v_x*B_x + v_y*B_y + v_z*B_z) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(vel_R(norm_dir)*(E_R + pres_R + pres_mag%R) - B%R(norm_dir) & - & *(vel_R(1)*B%R(1) + vel_R(2)*B%R(2) + vel_R(3)*B%R(3))) - s_P*(vel_L(norm_dir) & - & *(E_L + pres_L + pres_mag%L) - B%L(norm_dir)*(vel_L(1)*B%L(1) + vel_L(2)*B%L(2) & - & + vel_L(3)*B%L(3))) + s_M*s_P*(E_L - E_R))/(s_M - s_P) - #:endif - else if (mhd .and. relativity) then - ! energy flux = m_${XYZ}$ - mass flux Hard-coded for single-component for now - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(cm%R(norm_dir) - Ga%R*alpha_rho_R(1)*vel_R(norm_dir)) & - & - s_P*(cm%L(norm_dir) - Ga%L*alpha_rho_L(1)*vel_L(norm_dir)) + s_M*s_P*(E_L - E_R)) & - & /(s_M - s_P) - else if (bubbles_euler) then - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R - ptilde_R) - s_P*vel_L(dir_idx(1) & - & )*(E_L + pres_L - ptilde_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*(vel_R_rms - vel_L_rms)/2._wp - else if (hypoelasticity) then - flux_tau_L = 0._wp; flux_tau_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_tau_L = flux_tau_L + tau_e_L(dir_idx_tau(i))*vel_L(dir_idx(i)) - flux_tau_R = flux_tau_R + tau_e_R(dir_idx_tau(i))*vel_R(dir_idx(i)) - end do - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*(vel_R(dir_idx(1))*(E_R + pres_R) - flux_tau_R) & - & - s_P*(vel_L(dir_idx(1))*(E_L + pres_L) - flux_tau_L) + s_M*s_P*(E_L - E_R))/(s_M & - & - s_P) - else - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = (s_M*vel_R(dir_idx(1))*(E_R + pres_R) - s_P*vel_L(dir_idx(1))*(E_L & - & + pres_L) + s_M*s_P*(E_L - E_R))/(s_M - s_P) + (s_M/s_L)*(s_P/s_R)*pcorr*(vel_R_rms & - & - vel_L_rms)/2._wp - end if - - ! Elastic Stresses - if (hypoelasticity) then - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 ! TODO: this indexing may be slow - flux_rsx_vf(${SF('')}$, & - & eqn_idx%stress%beg - 1 + i) = (s_M*(rho_R*vel_R(dir_idx(1))*tau_e_R(i)) & - & - s_P*(rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + s_M*s_P*(rho_L*tau_e_L(i) & - & - rho_R*tau_e_R(i)))/(s_M - s_P) - end do - end if - - ! Advection flux and source: interface velocity for volume fraction transport - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = (qL_prim_rsx_vf(${SF('')}$, i) - qR_prim_rsx_vf(${SF(' + 1')}$, & - & i))*s_M*s_P/(s_M - s_P) - flux_src_rsx_vf(${SF('')}$, i) = (s_M*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i) - s_P*qL_prim_rsx_vf(${SF('')}$, i))/(s_M - s_P) - end do - - if (bubbles_euler) then - ! From HLLC: Kills mass transport @ bubble gas density - if (num_fluids > 1) then - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp - end if - end if - - if (chemistry) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Y_L = qL_prim_rsx_vf(${SF('')}$, i) - Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) - - flux_rsx_vf(${SF('')}$, & - & i) = (s_M*Y_R*rho_R*vel_R(dir_idx(1)) - s_P*Y_L*rho_L*vel_L(dir_idx(1)) & - & + s_M*s_P*(Y_L*rho_L - Y_R*rho_R))/(s_M - s_P) - flux_src_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - - ! MHD: magnetic flux and Maxwell stress contributions - if (mhd) then - if (n == 0) then ! 1D: d/dx flux only & Bx = Bx0 = const. - ! B_y flux = v_x * B_y - v_y * Bx0 B_z flux = v_x * B_z - v_z * Bx0 - $:GPU_LOOP(parallelism='[seq]') - do i = 0, 1 - flux_rsx_vf(j, k, l, & - & eqn_idx%B%beg + i) = (s_M*(vel_R(1)*B%R(2 + i) - vel_R(2 + i)*Bx0) & - & - s_P*(vel_L(1)*B%L(2 + i) - vel_L(2 + i)*Bx0) + s_M*s_P*(B%L(2 + i) & - & - B%R(2 + i)))/(s_M - s_P) - end do - else ! 2D/3D: Bx, By, Bz /= const. but zero flux component in the same direction - ! B_x d/d${XYZ}$ flux = (1 - delta(x,${XYZ}$)) * (v_${XYZ}$ * B_x - v_x * B_${XYZ}$) B_y - ! d/d${XYZ}$ flux = (1 - delta(y,${XYZ}$)) * (v_${XYZ}$ * B_y - v_y * B_${XYZ}$) B_z d/d${XYZ}$ - ! flux = (1 - delta(z,${XYZ}$)) * (v_${XYZ}$ * B_z - v_z * B_${XYZ}$) - $:GPU_LOOP(parallelism='[seq]') - do i = 0, 2 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%B%beg + i) = (1 - dir_flg(i + 1))*(s_M*(vel_R(dir_idx(1))*B%R(i + 1) & - & - vel_R(i + 1)*B%R(norm_dir)) - s_P*(vel_L(dir_idx(1))*B%L(i + 1) - vel_L(i & - & + 1)*B%L(norm_dir)) + s_M*s_P*(B%L(i + 1) - B%R(i + 1)))/(s_M - s_P) - end do - end if - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = 0._wp - end if - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + 2) - (s_M*pres_R - s_P*pres_L)/(s_M - s_P) - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - end if - - if (cyl_coord .and. hypoelasticity) then - ! += tau_sigmasigma using HLL - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%cont%end + 2) = flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + 2) + (s_M*tau_e_R(4) - s_P*tau_e_L(4))/(s_M - s_P) - - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%stress%beg, eqn_idx%stress%end - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - #:endfor - - if (viscous) then - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, idx_right_phys, vel_grad_L, vel_grad_R, alpha_L, alpha_R, & - & vel_L, vel_R, Re_L, Re_R]', copyin='[norm_dir]') - do l = isz%beg, isz%end - do k = isy%beg, isy%end - do j = isx%beg, isx%end - idx_right_phys(1) = j - idx_right_phys(2) = k - idx_right_phys(3) = l - idx_right_phys(norm_dir) = idx_right_phys(norm_dir) + 1 - - if (norm_dir == 1) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(j + 1, k, l, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) - vel_R(i) = qR_prim_rsx_vf(j + 1, k, l, eqn_idx%mom%beg + i - 1) - end do - else if (norm_dir == 2) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(j, k + 1, l, eqn_idx%E + i) - end do - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) - vel_R(i) = qR_prim_rsx_vf(j, k + 1, l, eqn_idx%mom%beg + i - 1) - end do - else - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(j, k, l + 1, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(j, k, l, eqn_idx%mom%beg + i - 1) - vel_R(i) = qR_prim_rsx_vf(j, k, l + 1, eqn_idx%mom%beg + i - 1) - end do - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - - if (shear_stress) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_grad_L(i, 1) = (dqL_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 1) = (dqR_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - vel_grad_L(i, 2) = (dqL_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 2) = (dqR_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) - end if - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - vel_grad_L(i, 3) = (dqL_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(1)) - vel_grad_R(i, 3) = (dqR_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(1)) - end if - #:endif - #:endif - end do - - if (norm_dir == 1) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(1)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(1) + vel_grad_R(2, & - & 2)*vel_R(1)) - - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, & - & 1) + vel_grad_R(2, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 2)*vel_L(2) + vel_grad_R(1, & - & 2)*vel_R(2)) - 0.5_wp*(vel_grad_L(2, 1)*vel_L(2) + vel_grad_R(2, 1)*vel_R(2)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, & - & 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 3) + vel_grad_R(1, & - & 3)) - 0.5_wp*(vel_grad_L(3, 1) + vel_grad_R(3, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 3)*vel_L(3) + vel_grad_R(1, & - & 3)*vel_R(3)) - 0.5_wp*(vel_grad_L(3, 1)*vel_L(3) + vel_grad_R(3, & - & 1)*vel_R(3)) - end if - #:endif - end if - #:endif - else if (norm_dir == 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) - - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(2)) - - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 2) + vel_grad_R(1, 2)) - 0.5_wp*(vel_grad_L(2, & - & 1) + vel_grad_R(2, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 2)*vel_L(1) + vel_grad_R(1, & - & 2)*vel_R(1)) - 0.5_wp*(vel_grad_L(2, 1)*vel_L(1) + vel_grad_R(2, 1)*vel_R(1)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, & - & k, l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, & - & 3)*vel_R(2)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, & - & k, l) - 0.5_wp*(vel_grad_L(2, 3) + vel_grad_R(2, & - & 3)) - 0.5_wp*(vel_grad_L(3, 2) + vel_grad_R(3, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 3)*vel_L(3) + vel_grad_R(2, & - & 3)*vel_R(3)) - 0.5_wp*(vel_grad_L(3, 2)*vel_L(3) + vel_grad_R(3, & - & 2)*vel_R(3)) - end if - #:endif - #:endif - else - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(1, 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (-2._wp/3._wp)*0.5_wp*(vel_grad_L(2, 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) - - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 3) + vel_grad_R(1, 3)) - 0.5_wp*(vel_grad_L(3, & - & 1) + vel_grad_R(3, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 3)*vel_L(1) + vel_grad_R(1, & - & 3)*vel_R(1)) - 0.5_wp*(vel_grad_L(3, 1)*vel_L(1) + vel_grad_R(3, 1)*vel_R(1)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - (4._wp/3._wp)*0.5_wp*(vel_grad_L(3, 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) - - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 3) + vel_grad_R(2, 3)) - 0.5_wp*(vel_grad_L(3, & - & 2) + vel_grad_R(3, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 3)*vel_L(2) + vel_grad_R(2, & - & 3)*vel_R(2)) - 0.5_wp*(vel_grad_L(3, 2)*vel_L(2) + vel_grad_R(3, 2)*vel_R(2)) - #:endif - end if - end if - - if (bulk_stress) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_grad_L(i, 1) = (dqL_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 1) = (dqR_prim_dx_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - vel_grad_L(i, 2) = (dqL_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 2) = (dqR_prim_dy_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) - end if - #:endif - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - vel_grad_L(i, 3) = (dqL_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(j, k, l)/Re_L(2)) - vel_grad_R(i, 3) = (dqR_prim_dz_vf(eqn_idx%mom%beg + i - 1)%sf(idx_right_phys(1), & - & idx_right_phys(2), idx_right_phys(3))/Re_R(2)) - end if - #:endif - end do - - if (norm_dir == 1) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, l) - 0.5_wp*(vel_grad_L(1, & - & 1)*vel_L(1) + vel_grad_R(1, 1)*vel_R(1)) - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - if (num_dims > 1) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(1) + vel_grad_R(2, 2)*vel_R(1)) - - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - flux_src_vf(eqn_idx%mom%beg)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(1) + vel_grad_R(3, 3)*vel_R(1)) - end if - #:endif - end if - #:endif - else if (norm_dir == 2) then - #:if not MFC_CASE_OPTIMIZATION or num_dims > 1 - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1)*vel_L(2) + vel_grad_R(1, 1)*vel_R(2)) - - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(2) + vel_grad_R(2, 2)*vel_R(2)) - - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - if (num_dims > 2) then - flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 1)%sf(j, & - & k, l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(2) + vel_grad_R(3, 3)*vel_R(2)) - end if - #:endif - #:endif - else - #:if not MFC_CASE_OPTIMIZATION or num_dims > 2 - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1) + vel_grad_R(1, 1)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(1, 1)*vel_L(3) + vel_grad_R(1, 1)*vel_R(3)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2) + vel_grad_R(2, 2)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(2, 2)*vel_L(3) + vel_grad_R(2, 2)*vel_R(3)) - - flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, l) = flux_src_vf(eqn_idx%mom%beg + 2)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3) + vel_grad_R(3, 3)) - flux_src_vf(eqn_idx%E)%sf(j, k, l) = flux_src_vf(eqn_idx%E)%sf(j, k, & - & l) - 0.5_wp*(vel_grad_L(3, 3)*vel_L(3) + vel_grad_R(3, 3)*vel_R(3)) - #:endif - end if - end if - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) - - end subroutine s_lf_riemann_solver - !> HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & From 69cf7e1d3d52db79c8efaa13c8f3edf4f204398f Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:31:47 -0400 Subject: [PATCH 09/11] src: split s_hllc_riemann_solver into m_riemann_solver_hllc NFC, pure motion; completes the m_riemann_solvers split. State access stays host-associated via m_riemann_state; hllc additionally uses m_bubbles (f_cpbw_KM), m_bubbles_EE (rs/vs/ps), and m_surface_tension (s_compute_capillary_source_flux). With the last solver body gone, core drops the use-lists whose final consumers moved (m_variables_conversion, m_bubbles, m_bubbles_EE, m_surface_tension, m_chemistry, m_thermochem, the m_constants only-list) and the inline_riemann include; core keeps the dispatcher, module init/finalize, and the public re-exports. Statement-multiset union vs the pre-split file differs only by module boilerplate; GPU-directive census md5 unchanged; declare-target scoping verified for all six files. --- docs/module_categories.json | 1 + src/simulation/m_riemann_solver_hllc.fpp | 1662 ++++++++++++++++++++++ src/simulation/m_riemann_solvers.fpp | 1644 +-------------------- 3 files changed, 1664 insertions(+), 1643 deletions(-) create mode 100644 src/simulation/m_riemann_solver_hllc.fpp diff --git a/docs/module_categories.json b/docs/module_categories.json index ebba674ba4..41788572b3 100644 --- a/docs/module_categories.json +++ b/docs/module_categories.json @@ -10,6 +10,7 @@ "m_riemann_solver_hlld", "m_riemann_solver_hll", "m_riemann_solver_lf", + "m_riemann_solver_hllc", "m_muscl", "m_variables_conversion", "m_thinc" diff --git a/src/simulation/m_riemann_solver_hllc.fpp b/src/simulation/m_riemann_solver_hllc.fpp new file mode 100644 index 0000000000..f8ed19379e --- /dev/null +++ b/src/simulation/m_riemann_solver_hllc.fpp @@ -0,0 +1,1662 @@ +!> +!! @file +!! @brief Contains module m_riemann_solver_hllc + +!> @brief HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) +#:include 'case.fpp' +#:include 'macros.fpp' +#:include 'inline_riemann.fpp' + +module m_riemann_solver_hllc + + use m_derived_types + use m_global_parameters + use m_variables_conversion + use m_bubbles + use m_constants, only: riemann_solver_hll, riemann_solver_hllc, riemann_solver_lax_friedrichs, model_eqns_5eq, & + & model_eqns_6eq, model_eqns_4eq, avg_state_roe, avg_state_arithmetic, wave_speeds_direct, wave_speeds_pressure + use m_bubbles_EE + use m_surface_tension + use m_chemistry + use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & + & get_mixture_energy_mass, get_species_specific_heats_r, get_species_enthalpies_rt, get_mixture_specific_heat_cp_mass, & + & molecular_weights + use m_riemann_state + + implicit none + +contains + + !> HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) + subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & + + & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & + & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) + + real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf + type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf + type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & + & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf + + ! Intercell fluxes + type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf + integer, intent(in) :: norm_dir + type(int_bounds_info), intent(in) :: ix, iy, iz + + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(3) :: alpha_L, alpha_R + real(wp), dimension(3) :: vel_L, vel_R + #:else + real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R + real(wp), dimension(num_fluids) :: alpha_L, alpha_R + real(wp), dimension(num_dims) :: vel_L, vel_R + #:endif + + real(wp) :: rho_L, rho_R + real(wp) :: pres_L, pres_R + real(wp) :: E_L, E_R + real(wp) :: H_L, H_R + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(10) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR + real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + #:else + real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR + real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 + #:endif + real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps + real(wp) :: T_L, T_R + real(wp) :: MW_L, MW_R + real(wp) :: R_gas_L, R_gas_R + real(wp) :: Cp_L, Cp_R + real(wp) :: Cv_L, Cv_R + real(wp) :: Gamm_L, Gamm_R + real(wp) :: Y_L, Y_R + real(wp) :: gamma_L, gamma_R + real(wp) :: pi_inf_L, pi_inf_R + real(wp) :: qv_L, qv_R + real(wp) :: c_L, c_R + real(wp), dimension(2) :: Re_L, Re_R + real(wp) :: rho_avg + real(wp) :: H_avg + real(wp) :: gamma_avg + real(wp) :: qv_avg + real(wp) :: c_avg + real(wp) :: s_L, s_R, s_M, s_P, s_S + real(wp) :: xi_L, xi_R !< Left and right wave speeds functions + real(wp) :: xi_L_m1, xi_R_m1 !< xi_L/R - 1, computed without cancellation + real(wp) :: xi_M, xi_P + real(wp) :: xi_MP, xi_PP + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: R0_L, R0_R + real(wp), dimension(3) :: V0_L, V0_R + real(wp), dimension(3) :: P0_L, P0_R + real(wp), dimension(3) :: pbw_L, pbw_R + #:else + real(wp), dimension(nb) :: R0_L, R0_R + real(wp), dimension(nb) :: V0_L, V0_R + real(wp), dimension(nb) :: P0_L, P0_R + real(wp), dimension(nb) :: pbw_L, pbw_R + #:endif + + real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L, nbub_R + real(wp) :: ptilde_L, ptilde_R + real(wp) :: PbwR3Lbar, PbwR3Rbar + real(wp) :: R3Lbar, R3Rbar + real(wp) :: R3V2Lbar, R3V2Rbar + real(wp), dimension(6) :: tau_e_L, tau_e_R + #:if not MFC_CASE_OPTIMIZATION and USING_AMD + real(wp), dimension(3) :: xi_field_L, xi_field_R + #:else + real(wp), dimension(num_dims) :: xi_field_L, xi_field_R + #:endif + real(wp) :: G_L, G_R + real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms + real(wp) :: vel_L_tmp, vel_R_tmp + real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star + real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R + real(wp) :: flux_ene_e + real(wp) :: zcoef, pcorr !< low Mach number correction + integer :: Re_max, 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, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & + & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) + + ! Reshaping inputted data based on dimensional splitting direction + + call s_initialize_riemann_solver(flux_src_vf, norm_dir) + + #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & + [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & + (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & + (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] + #:set SV = STENCIL_VAR + #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) + if (norm_dir == ${NORM_DIR}$) then + ! 6-EQUATION MODEL WITH HLLC HLLC star-state flux with contact wave speed s_S + if (model_eqns == model_eqns_6eq) then + ! 6-equation model (model_eqns=3): separate phasic internal energies + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, vel_L, vel_R, Re_L, Re_R, alpha_L, alpha_R, Ys_L, & + & Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, & + & h_avg_2, tau_e_L, tau_e_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, zcoef, rho_L, & + & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, & + & T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & + & Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, G_L, G_R, & + & rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & + & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & + & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & + & xi_M, xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + alpha_L_sum = 0._wp; alpha_R_sum = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + rho_L = 0._wp + gamma_L = 0._wp + pi_inf_L = 0._wp + qv_L = 0._wp + + rho_R = 0._wp + gamma_R = 0._wp + pi_inf_R = 0._wp + qv_R = 0._wp + + alpha_L_sum = 0._wp + alpha_R_sum = 0._wp + + if (mpp_lim) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + qL_prim_rsx_vf(${SF('')}$, i) = max(0._wp, qL_prim_rsx_vf(${SF('')}$, i)) + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = min(max(0._wp, qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%E + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + qR_prim_rsx_vf(${SF(' + 1')}$, i) = max(0._wp, qR_prim_rsx_vf(${SF(' + 1')}$, i)) + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = min(max(0._wp, & + & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)), 1._wp) + alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%E + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = qR_prim_rsx_vf(${SF(' + 1')}$, & + & eqn_idx%E + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) + gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) + + rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) + gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) + + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%adv%beg + i - 1) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%adv%beg + i - 1) + end do + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + Re_idx(i, q))/Res_gs(i, & + & q) + Re_R(i) + end do + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms + qv_R + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + end do + G_L = 0._wp; G_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + ! Hyperelastic stress contribution: strain energy added to total energy + if (hyperelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + xi_field_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%beg - 1 + i) + xi_field_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%beg - 1 + i) + end do + G_L = 0._wp; G_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%end + 1) + E_R = E_R + G_R*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%end + 1) + end if + $:GPU_LOOP(parallelism='[seq]') + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + end do + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & + & c_L, qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & + & c_R, qv_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & + & 0._wp, c_avg, qv_avg) + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + ! COMPUTING THE DIRECT WAVE SPEEDS + if (wave_speeds == wave_speeds_direct) then + if (elasticity) then + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & + & ))/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & + & ))/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & + & + rho_L*vel_L(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)))) + else + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & + & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & + & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) + end if + else if (wave_speeds == wave_speeds_pressure) then + pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + ! 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)))/min(s_L - s_S, -sgm_eps) + xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) + xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + + ! goes with numerical star velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5.e-1_wp + sign(0.5_wp, s_S)) + xi_P = (5.e-1_wp - sign(0.5_wp, s_S)) + + ! goes with the numerical velocity in x/y/z directions xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) + xi_MP = -min(0._wp, sign(1._wp, s_L)) + xi_PP = max(0._wp, sign(1._wp, s_R)) + + E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))*(rho_L*s_S + pres_L/(s_L & + & - vel_L(dir_idx(1))))) - E_L)) + xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S & + & - vel_R(dir_idx(1)))*(rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) + p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) & + & + xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) + + rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) + + vel_K_Star = vel_L(dir_idx(1))*(1._wp - xi_MP) + xi_MP*vel_R(dir_idx(1)) + xi_MP*xi_PP*(s_S & + & - vel_R(dir_idx(1))) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING FLUXES MASS FLUX. + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! MOMENTUM FLUX. f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = rho_Star*vel_K_Star*(dir_flg(dir_idx(i)) & + & *vel_K_Star + (1._wp - dir_flg(dir_idx(i)))*(xi_M*vel_L(dir_idx(i)) & + & + xi_P*vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star + (s_M/s_L)*(s_P/s_R) & + & *dir_flg(dir_idx(i))*pcorr + end do + + ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + flux_rsx_vf(${SF('')}$, eqn_idx%E) = (E_star + p_Star)*vel_K_Star + (s_M/s_L)*(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + ! MOMENTUM ELASTIC FLUX. + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & + & - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - xi_M*(vel_L(dir_idx(i))*tau_e_L(dir_idx_tau(i)) & + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i)) & + & /(s_L - vel_L(i)))))) - xi_P*(vel_R(dir_idx(i)) & + & *tau_e_R(dir_idx_tau(i)) + s_P*(xi_R*((s_S - vel_R(i)) & + & *(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rsx_vf(${SF('')}$, eqn_idx%E) = flux_rsx_vf(${SF('')}$, eqn_idx%E) + flux_ene_e + end if + + ! VOLUME FRACTION FLUX. + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*s_S + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, i)*s_S + end do + + ! Advection velocity source: interface velocity for volume fraction transport + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_src_rsx_vf(${SF('')}$, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & + & *(s_S*(xi_MP*xi_L_m1 + 1) - vel_L(dir_idx(i)))) + xi_P*(vel_R(dir_idx(i)) & + & + dir_flg(dir_idx(i))*(s_S*(xi_PP*xi_R_m1 + 1) - vel_R(dir_idx(i)))) + end do + + ! INTERNAL ENERGIES ADVECTION FLUX. K-th pressure and velocity in preparation for the internal + ! energy flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1._wp + gammas(i)))*xi_L**(1._wp/gammas(i) & + & + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_L) + pres_L) & + & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1._wp + gammas(i))) & + & *xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_R) & + & + pres_R) + + flux_rsx_vf(${SF('')}$, i + eqn_idx%int_en%beg - 1) = ((xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i + eqn_idx%adv%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i + eqn_idx%adv%beg - 1))*(gammas(i)*p_K_Star + pi_infs(i)) & + & + (xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i + eqn_idx%cont%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i + eqn_idx%cont%beg - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & + & *pcorr*s_S*(xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i + eqn_idx%adv%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i + eqn_idx%adv%beg - 1)) + end do + + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%stress%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & + & - rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + xi_P*(s_S/(s_R - s_S)) & + & *(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(dir_idx(1))*tau_e_R(i)) + end do + end if + + ! Hyperelastic reference map flux for material deformation tracking + if (hyperelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%xi%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + & - rho_L*vel_L(dir_idx(1))*xi_field_L(i)) + xi_P*(s_S/(s_R - s_S)) & + & *(s_R*rho_R*xi_field_R(i) - rho_R*vel_R(dir_idx(1))*xi_field_R(i)) + end do + end if + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rsx_vf(${SF('')}$, eqn_idx%c) = (xi_M*qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%c) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%c))*s_S + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%int_en%beg, eqn_idx%int_en%end + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg - 1 + dir_idx(1)) = flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg - 1 + dir_idx(1)) - p_Star + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, sys_size + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg - 1 + dir_idx(1)) = flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg - 1 + dir_idx(1)) - p_Star + + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + else if (model_eqns == model_eqns_4eq) then + ! 4-equation model (model_eqns=4): single pressure, velocity equilibrium + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & + & nbub_L, nbub_R, rho_L, rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, & + & T_avg, eps, c_sum_Yi_Phi, T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, & + & Gamm_L, Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, & + & G_L, G_R, rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & + & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & + & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & + & xi_M, xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP, Ys_L, Ys_R, Cp_iL, Cp_iR, Xs_L, & + & Xs_R, Gamma_iL, Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) + alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + alpha_rho_L(i) + gamma_L = gamma_L + alpha_L(i)*gammas(i) + pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) + qv_L = qv_L + alpha_rho_L(i)*qvs(i) + + rho_R = rho_R + alpha_rho_R(i) + gamma_R = gamma_R + alpha_R(i)*gammas(i) + pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) + qv_R = qv_R + alpha_rho_R(i)*qvs(i) + end do + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & + & c_L, qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & + & c_R, qv_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & + & 0._wp, c_avg, qv_avg) + + if (wave_speeds == wave_speeds_direct) 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)))) + else if (wave_speeds == wave_speeds_pressure) then + pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + ! 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)))/min(s_L - s_S, -sgm_eps) + xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) + xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + + ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) + xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, & + & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*alpha_rho_R(i) & + & *(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! Momentum flux. f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & + & ) + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) + end do + + if (bubbles_euler) then + ! Put p_tilde in + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L) & + & ) + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) + end do + end if + + flux_rsx_vf(${SF('')}$, eqn_idx%E) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%alf, eqn_idx%alf ! only advect the void fraction + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! Advection velocity source: interface velocity for volume fraction transport + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_src_rsx_vf(${SF('')}$, dir_idx(i)) = 0._wp + ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + end do + + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) + + ! Add advection flux for bubble variables + if (bubbles_euler) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%bub%beg, eqn_idx%bub%end + flux_rsx_vf(${SF('')}$, i) = xi_M*nbub_L*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*nbub_R*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + end if + + ! Geometrical source flux for cylindrical coordinates + + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, sys_size + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & + & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + else if (model_eqns == model_eqns_5eq .and. bubbles_euler) then + ! 5-equation model with Euler-Euler bubble dynamics + $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, & + & vel_R, rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, Re_L, Re_R, pcorr, zcoef, rho_L, & + & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, & + & qv_R, qv_avg, c_L, c_R, c_avg, vel_L_rms, vel_R_rms, vel_avg_rms, vel_L_tmp, vel_R_tmp, & + & Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, alpha_R_sum, s_L, s_R, s_M, s_P, s_S, xi_M, & + & xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, & + & R3Lbar, R3Rbar, R3V2Lbar, R3V2Rbar, Ys_L, Ys_R, Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, & + & Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + vel_L_rms = 0._wp; vel_R_rms = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + ! Retain this in the refactor + if (mpp_lim .and. (num_fluids > 2)) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) + gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) + rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) + gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) + end do + else if (num_fluids > 2) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids - 1 + rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) + gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) + rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) + gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) + end do + else + rho_L = qL_prim_rsx_vf(${SF('')}$, 1) + gamma_L = gammas(1) + pi_inf_L = pi_infs(1) + qv_L = qvs(1) + rho_R = qR_prim_rsx_vf(${SF(' + 1')}$, 1) + gamma_R = gammas(1) + pi_inf_R = pi_infs(1) + qv_R = qvs(1) + end if + + if (viscous) then + if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_L(i) = dflt_real + Re_R(i) = dflt_real + + if (Re_size(i) > 0) Re_L(i) = 0._wp + if (Re_size(i) > 0) Re_R(i) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = (1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + Re_idx(i, & + & q)))/Res_gs(i, q) + Re_L(i) + Re_R(i) = (1._wp - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + Re_idx(i, & + & q)))/Res_gs(i, q) + Re_R(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + end if + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + if (avg_state == avg_state_arithmetic) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, nb + R0_L(i) = qL_prim_rsx_vf(${SF('')}$, rs(i)) + R0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, rs(i)) + + V0_L(i) = qL_prim_rsx_vf(${SF('')}$, vs(i)) + V0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, vs(i)) + if (.not. polytropic .and. .not. qbmm) then + P0_L(i) = qL_prim_rsx_vf(${SF('')}$, ps(i)) + P0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, ps(i)) + end if + end do + + if (.not. qbmm) then + if (adv_n) then + nbub_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%n) + nbub_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%n) + else + nbub_L = 0._wp + nbub_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, nb + nbub_L = nbub_L + (R0_L(i)**3._wp)*weight(i) + nbub_R = nbub_R + (R0_R(i)**3._wp)*weight(i) + end do + + nbub_L = (3._wp/(4._wp*pi))*qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + num_fluids)/nbub_L + nbub_R = (3._wp/(4._wp*pi))*qR_prim_rsx_vf(${SF(' + 1')}$, & + & eqn_idx%E + num_fluids)/nbub_R + end if + else + ! nb stored in 0th moment of first R0 bin in variable conversion module + nbub_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%bub%beg) + nbub_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%bub%beg) + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, nb + if (.not. qbmm) then + 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 do + + if (qbmm) then + PbwR3Lbar = mom_sp_rsx_vf(${SF('')}$, 4) + PbwR3Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 4) + + R3Lbar = mom_sp_rsx_vf(${SF('')}$, 1) + R3Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 1) + + R3V2Lbar = mom_sp_rsx_vf(${SF('')}$, 3) + R3V2Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 3) + else + PbwR3Lbar = 0._wp + PbwR3Rbar = 0._wp + + R3Lbar = 0._wp + R3Rbar = 0._wp + + R3V2Lbar = 0._wp + R3V2Rbar = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, nb + PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) + PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) + + R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) + R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) + + R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) + R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) + end do + end if + + rho_avg = 5.e-1_wp*(rho_L + rho_R) + H_avg = 5.e-1_wp*(H_L + H_R) + gamma_avg = 5.e-1_wp*(gamma_L + gamma_R) + qv_avg = 5.e-1_wp*(qv_L + qv_R) + vel_avg_rms = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_avg_rms = vel_avg_rms + (5.e-1_wp*(vel_L(i) + vel_R(i)))**2._wp + end do + end if + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & + & c_L, qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & + & c_R, qv_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & + & 0._wp, c_avg, qv_avg) + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + if (wave_speeds == wave_speeds_direct) 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)))) + else if (wave_speeds == wave_speeds_pressure) then + pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + ! 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)))/min(s_L - s_S, -sgm_eps) + xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) + xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + + ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) + xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + if (bubbles_euler .and. (num_fluids > 1)) then + ! Kill mass transport @ gas density + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp + end if + + ! Momentum flux. f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) + + ! Include p_tilde + + if (avg_state == avg_state_arithmetic) then + if (alpha_L(num_fluids) < small_alf .or. R3Lbar < small_alf) then + pres_L = pres_L - alpha_L(num_fluids)*pres_L + else + pres_L = pres_L - alpha_L(num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - rho_L*R3V2Lbar/R3Lbar) + end if + + if (alpha_R(num_fluids) < small_alf .or. R3Rbar < small_alf) then + pres_R = pres_R - alpha_R(num_fluids)*pres_R + else + pres_R = pres_R - alpha_R(num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - rho_R*R3V2Rbar/R3Rbar) + end if + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & + & ) + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & + & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & + & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & + & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + end do + + ! Energy flux. f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + s_M*(xi_L*(E_L + (s_S & + & - vel_L(dir_idx(1)))*(rho_L*s_S + (pres_L)/(s_L - vel_L(dir_idx(1))))) - E_L)) & + & + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R) + s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)) & + & )*(rho_R*s_S + (pres_R)/(s_R - vel_R(dir_idx(1))))) - E_R)) + (s_M/s_L)*(s_P/s_R) & + & *pcorr*s_S + + ! Volume fraction flux + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! Advection velocity source: interface velocity for volume fraction transport + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_src_rsx_vf(${SF('')}$, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*xi_L_m1) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*xi_R_m1) + + ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp + end do + + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) + + ! Add advection flux for bubble variables + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%bub%beg, eqn_idx%bub%end + flux_rsx_vf(${SF('')}$, i) = xi_M*nbub_L*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*nbub_R*qR_prim_rsx_vf(${SF(' + 1')}$, i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + if (qbmm) then + flux_rsx_vf(${SF('')}$, & + & eqn_idx%bub%beg) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end if + + if (adv_n) then + flux_rsx_vf(${SF('')}$, & + & eqn_idx%n) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, sys_size + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & + & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + else + ! 5-equation model (model_eqns=2): mixture total energy, volume fraction advection + $:GPU_PARALLEL_LOOP(collapse=3, private='[Re_max, i, q, T_L, T_R, vel_L_rms, vel_R_rms, pres_L, pres_R, & + & rho_L, gamma_L, pi_inf_L, qv_L, rho_R, gamma_R, pi_inf_R, qv_R, alpha_L_sum, & + & alpha_R_sum, E_L, E_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & + & Gamm_R, Y_L, Y_R, H_L, H_R, qv_avg, rho_avg, gamma_avg, H_avg, c_L, c_R, c_avg, s_P, & + & s_M, xi_P, xi_M, xi_L, xi_R, xi_L_m1, xi_R_m1, Ms_L, Ms_R, pres_SL, pres_SR, vel_L, & + & vel_R, Re_L, Re_R, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & + & vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & + & tau_e_L, tau_e_R, xi_field_L, xi_field_R, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, G_L, & + & G_R]', copyin='[is1, is2, is3]') + do l = ${Z_BND}$%beg, ${Z_BND}$%end + do k = ${Y_BND}$%beg, ${Y_BND}$%end + do j = ${X_BND}$%beg, ${X_BND}$%end + vel_L_rms = 0._wp; vel_R_rms = 0._wp + rho_L = 0._wp; rho_R = 0._wp + gamma_L = 0._wp; gamma_R = 0._wp + pi_inf_L = 0._wp; pi_inf_R = 0._wp + qv_L = 0._wp; qv_R = 0._wp + alpha_L_sum = 0._wp; alpha_R_sum = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) + vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) + vel_L_rms = vel_L_rms + vel_L(i)**2._wp + vel_R_rms = vel_R_rms + vel_R(i)**2._wp + end do + + pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) + pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) + + ! Change this by splitting it into the cases present in the bubbles_euler + if (mpp_lim) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + qL_prim_rsx_vf(${SF('')}$, i) = max(0._wp, qL_prim_rsx_vf(${SF('')}$, i)) + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = min(max(0._wp, qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%E + i)), 1._wp) + qR_prim_rsx_vf(${SF(' + 1')}$, i) = max(0._wp, qR_prim_rsx_vf(${SF(' + 1')}$, i)) + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = min(max(0._wp, & + & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)), 1._wp) + alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) + alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) + end do + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%E + i)/max(alpha_L_sum, sgm_eps) + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = qR_prim_rsx_vf(${SF(' + 1')}$, & + & eqn_idx%E + i)/max(alpha_R_sum, sgm_eps) + end do + end if + + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) + gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) + pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) + qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) + + rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) + gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) + pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) + qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) + end do + + Re_max = 0 + if (Re_size(1) > 0) Re_max = 1 + if (Re_size(2) > 0) Re_max = 2 + + if (viscous) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, Re_max + Re_L(i) = 0._wp + Re_R(i) = 0._wp + + $:GPU_LOOP(parallelism='[seq]') + do q = 1, Re_size(i) + Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) + Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) + end do + + Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) + Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) + end do + end if + + if (chemistry) then + c_sum_Yi_Phi = 0.0_wp + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) + Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) + end do + + call get_mixture_molecular_weight(Ys_L, MW_L) + call get_mixture_molecular_weight(Ys_R, MW_R) + + Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) + Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) + + R_gas_L = gas_constant/MW_L + R_gas_R = gas_constant/MW_R + + T_L = pres_L/rho_L/R_gas_L + T_R = pres_R/rho_R/R_gas_R + + call get_species_specific_heats_r(T_L, Cp_iL) + call get_species_specific_heats_r(T_R, Cp_iR) + + if (chem_params%gamma_method == 1) then + !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. + Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) + Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) + + gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) + gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) + else if (chem_params%gamma_method == 2) then + !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. + call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) + call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) + call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) + call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) + + Gamm_L = Cp_L/Cv_L; Gamm_R = Cp_R/Cv_R + gamma_L = 1.0_wp/(Gamm_L - 1.0_wp); gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) + end if + + call get_mixture_energy_mass(T_L, Ys_L, E_L) + call get_mixture_energy_mass(T_R, Ys_R, E_R) + + E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms + E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + else + E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L + E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + end if + + ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY + if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + end do + G_L = 0._wp + G_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + ! Elastic contribution to energy if G large enough + if ((G_L > verysmall) .and. (G_R > verysmall)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + ! Additional terms in 2D and 3D + if ((i == 2) .or. (i == 4) .or. (i == 5)) then + E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) + E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) + end if + end if + end do + end if + + ! Hyperelastic stress contribution: strain energy added to total energy + if (hyperelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + xi_field_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%beg - 1 + i) + xi_field_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%beg - 1 + i) + end do + G_L = 0._wp + G_R = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_fluids + ! Mixture left and right shear modulus + G_L = G_L + alpha_L(i)*Gs_rs(i) + G_R = G_R + alpha_R(i)*Gs_rs(i) + end do + ! Elastic contribution to energy if G large enough + if (G_L > verysmall .and. G_R > verysmall) then + E_L = E_L + G_L*qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%end + 1) + E_R = E_R + G_R*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%end + 1) + end if + $:GPU_LOOP(parallelism='[seq]') + do i = 1, b_size - 1 + tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) + tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) + end do + end if + + H_L = (E_L + pres_L)/rho_L + H_R = (E_R + pres_R)/rho_R + + @:compute_average_state() + + call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & + & c_L, qv_L) + + call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & + & c_R, qv_R) + + !> The computation of c_avg does not require all the variables, and therefore the non '_avg' + ! variables are placeholders to call the subroutine. + call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & + & c_sum_Yi_Phi, c_avg, qv_avg) + + if (viscous) then + if (chemistry) then + call compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L(1), Re_R(1)) + end if + $:GPU_LOOP(parallelism='[seq]') + do i = 1, 2 + Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) + end do + end if + + ! Low Mach correction + if (low_Mach == 2) then + @:compute_low_Mach_correction() + end if + + if (wave_speeds == wave_speeds_direct) then + if (elasticity) then + ! Elastic wave speed, Rodriguez et al. JCP (2019) + s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & + & ))/rho_L), & + & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & + & + tau_e_R(dir_idx_tau(1)))/rho_R)) + s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & + & ))/rho_R), & + & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & + & + tau_e_L(dir_idx_tau(1)))/rho_L)) + s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & + & + rho_L*vel_L(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)))) + else + s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) + s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) + s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & + & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & + & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) + end if + else if (wave_speeds == wave_speeds_pressure) then + pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) + + pres_SR = pres_SL + + ! Low Mach correction: Thornber et al. JCP (2008) + Ms_L = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & + & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) + Ms_R = max(1._wp, & + & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & + & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) + + s_L = vel_L(dir_idx(1)) - c_L*Ms_L + s_R = vel_R(dir_idx(1)) + c_R*Ms_R + + s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) + end if + + ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) + s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) + + ! 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)))/min(s_L - s_S, -sgm_eps) + xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + ! xi_L/R - 1 = (s_S - u_L/R)/(s_L/R - s_star): avoids cancellation when xi \approx 1 + xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) + xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) + + ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) + xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) + xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) + + ! Low Mach correction + if (low_Mach == 1) then + @:compute_low_Mach_correction() + else + pcorr = 0._wp + end if + + ! COMPUTING THE HLLC FLUXES MASS FLUX. + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%cont%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! MOMENTUM FLUX. f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) identity: + ! xi*(dir_flg*s_S+(1-dir_flg)*u_i)-u_i = (dir_flg*s_L/R+(1-dir_flg)*u_i)*xi_m1 + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & + & ) + s_M*(dir_flg(dir_idx(i))*s_L + (1._wp - dir_flg(dir_idx(i))) & + & *vel_L(dir_idx(i)))*xi_L_m1) + dir_flg(dir_idx(i))*(pres_L)) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) + s_P*(dir_flg(dir_idx(i)) & + & *s_R + (1._wp - dir_flg(dir_idx(i)))*vel_R(dir_idx(i)))*xi_R_m1) & + & + dir_flg(dir_idx(i))*(pres_R)) + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr + end do + + ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) + ! xi*(E+expr)-E = E*xi_m1 + xi*expr avoids E*(xi-1) cancellation + flux_rsx_vf(${SF('')}$, & + & eqn_idx%E) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + s_M*(E_L*xi_L_m1 + xi_L*(s_S & + & - vel_L(dir_idx(1)))*(rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1)))))) & + & + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R) + s_P*(E_R*xi_R_m1 + xi_R*(s_S & + & - vel_R(dir_idx(1)))*(rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1)))))) + (s_M/s_L) & + & *(s_P/s_R)*pcorr*s_S + + ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux + if (elasticity) then + flux_ene_e = 0._wp + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + ! MOMENTUM ELASTIC FLUX. + flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & + & - xi_P*tau_e_R(dir_idx_tau(i)) + ! ENERGY ELASTIC FLUX. + flux_ene_e = flux_ene_e - xi_M*(vel_L(dir_idx(i))*tau_e_L(dir_idx_tau(i)) & + & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i)) & + & /(s_L - vel_L(i)))))) - xi_P*(vel_R(dir_idx(i)) & + & *tau_e_R(dir_idx_tau(i)) + s_P*(xi_R*((s_S - vel_R(i)) & + & *(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) + end do + flux_rsx_vf(${SF('')}$, eqn_idx%E) = flux_rsx_vf(${SF('')}$, eqn_idx%E) + flux_ene_e + end if + + ! HYPOELASTIC STRESS EVOLUTION FLUX. + if (hypoelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 + flux_rsx_vf(${SF('')}$, & + & eqn_idx%stress%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & + & - rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + xi_P*(s_S/(s_R - s_S)) & + & *(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(dir_idx(1))*tau_e_R(i)) + end do + end if + + ! VOLUME FRACTION FLUX. + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & + & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end do + + ! VOLUME FRACTION SOURCE FLUX. + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + vel_src_rsx_vf(${SF('')}$, & + & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*xi_L_m1) & + & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*xi_R_m1) + end do + + ! COLOR FUNCTION FLUX + if (surface_tension) then + flux_rsx_vf(${SF('')}$, eqn_idx%c) = xi_M*qL_prim_rsx_vf(${SF('')}$, & + & eqn_idx%c)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%c)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + end if + + ! Hyperelastic reference map flux for material deformation tracking + if (hyperelasticity) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, num_dims + flux_rsx_vf(${SF('')}$, & + & eqn_idx%xi%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & + & - rho_L*vel_L(dir_idx(1))*xi_field_L(i)) + xi_P*(s_S/(s_R - s_S)) & + & *(s_R*rho_R*xi_field_R(i) - rho_R*vel_R(dir_idx(1))*xi_field_R(i)) + end do + end if + + flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) + + if (chemistry) then + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%species%beg, eqn_idx%species%end + Y_L = qL_prim_rsx_vf(${SF('')}$, i) + Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) + + flux_rsx_vf(${SF('')}$, & + & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & + & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) + flux_src_rsx_vf(${SF('')}$, i) = 0.0_wp + end do + end if + + ! Geometrical source flux for cylindrical coordinates + #:if (NORM_DIR == 2) + if (cyl_coord) then + ! Substituting the advective flux into the inviscid geometrical source flux + $:GPU_LOOP(parallelism='[seq]') + do i = 1, eqn_idx%E + flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) + end do + ! Recalculating the radial momentum geometric source flux + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & + & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & + & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + ! Geometrical source of the void fraction(s) is zero + $:GPU_LOOP(parallelism='[seq]') + do i = eqn_idx%adv%beg, eqn_idx%adv%end + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + end if + #:endif + #:if (NORM_DIR == 3) + if (grid_geometry == 3) then + $:GPU_LOOP(parallelism='[seq]') + do i = 1, sys_size + flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp + end do + + flux_gsrc_rsx_vf(${SF('')}$, & + & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & + & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & + & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & + & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & + & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) + flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) + end if + #:endif + end do + end do + end do + $:END_GPU_PARALLEL_LOOP() + end if + end if + #:endfor + ! Computing HLLC flux and source flux for Euler system of equations + + if (viscous) then + if (weno_Re_flux) then + call s_compute_viscous_source_flux(qL_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & qR_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & + & norm_dir, ix, iy, iz) + else + call s_compute_viscous_source_flux(q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & + & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & + & norm_dir, ix, iy, iz) + end if + end if + + if (surface_tension) then + call s_compute_capillary_source_flux(vel_src_rsx_vf, flux_src_vf, norm_dir, isx, isy, isz) + end if + + call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) + + end subroutine s_hllc_riemann_solver + +end module m_riemann_solver_hllc diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index 6bbc938ecd..e3f00a69eb 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -6,28 +6,18 @@ #:include 'case.fpp' #:include 'macros.fpp' -#:include 'inline_riemann.fpp' module m_riemann_solvers use m_derived_types use m_global_parameters use m_mpi_proxy - use m_variables_conversion - use m_bubbles - use m_constants, only: riemann_solver_hll, riemann_solver_hllc, riemann_solver_hlld, riemann_solver_lax_friedrichs, & - & model_eqns_5eq, model_eqns_6eq, model_eqns_4eq, avg_state_roe, avg_state_arithmetic, wave_speeds_direct, & - & wave_speeds_pressure - use m_bubbles_EE - use m_surface_tension use m_helper_basic use m_riemann_state + use m_riemann_solver_hllc use m_riemann_solver_lf use m_riemann_solver_hll use m_riemann_solver_hlld - use m_chemistry - use m_thermochem, only: gas_constant, get_mixture_molecular_weight, get_mixture_specific_heat_cv_mass, & - & get_mixture_energy_mass, get_species_specific_heats_r, get_species_enthalpies_rt, get_mixture_specific_heat_cp_mass implicit none @@ -63,1638 +53,6 @@ contains end subroutine s_riemann_solver - !> HLLC Riemann solver with contact restoration, Toro et al. Shock Waves (1994) - subroutine s_hllc_riemann_solver(qL_prim_rsx_vf, dqL_prim_dx_vf, dqL_prim_dy_vf, & - - & dqL_prim_dz_vf, qL_prim_vf, qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, qR_prim_vf, q_prim_vf, & - & flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir, ix, iy, iz) - - real(wp), dimension(idwbuff(1)%beg:,idwbuff(2)%beg:,idwbuff(3)%beg:,1:), intent(inout) :: qL_prim_rsx_vf, qR_prim_rsx_vf - type(scalar_field), dimension(sys_size), intent(in) :: q_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: qL_prim_vf, qR_prim_vf - type(scalar_field), allocatable, dimension(:), intent(inout) :: dqL_prim_dx_vf, dqR_prim_dx_vf, dqL_prim_dy_vf, & - & dqR_prim_dy_vf, dqL_prim_dz_vf, dqR_prim_dz_vf - - ! Intercell fluxes - type(scalar_field), dimension(sys_size), intent(inout) :: flux_vf, flux_src_vf, flux_gsrc_vf - integer, intent(in) :: norm_dir - type(int_bounds_info), intent(in) :: ix, iy, iz - - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(3) :: alpha_L, alpha_R - real(wp), dimension(3) :: vel_L, vel_R - #:else - real(wp), dimension(num_fluids) :: alpha_rho_L, alpha_rho_R - real(wp), dimension(num_fluids) :: alpha_L, alpha_R - real(wp), dimension(num_dims) :: vel_L, vel_R - #:endif - - real(wp) :: rho_L, rho_R - real(wp) :: pres_L, pres_R - real(wp) :: E_L, E_R - real(wp) :: H_L, H_R - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(10) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR - real(wp), dimension(10) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - #:else - real(wp), dimension(num_species) :: Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR - real(wp), dimension(num_species) :: Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2 - #:endif - real(wp) :: Cp_avg, Cv_avg, T_avg, c_sum_Yi_Phi, eps - real(wp) :: T_L, T_R - real(wp) :: MW_L, MW_R - real(wp) :: R_gas_L, R_gas_R - real(wp) :: Cp_L, Cp_R - real(wp) :: Cv_L, Cv_R - real(wp) :: Gamm_L, Gamm_R - real(wp) :: Y_L, Y_R - real(wp) :: gamma_L, gamma_R - real(wp) :: pi_inf_L, pi_inf_R - real(wp) :: qv_L, qv_R - real(wp) :: c_L, c_R - real(wp), dimension(2) :: Re_L, Re_R - real(wp) :: rho_avg - real(wp) :: H_avg - real(wp) :: gamma_avg - real(wp) :: qv_avg - real(wp) :: c_avg - real(wp) :: s_L, s_R, s_M, s_P, s_S - real(wp) :: xi_L, xi_R !< Left and right wave speeds functions - real(wp) :: xi_L_m1, xi_R_m1 !< xi_L/R - 1, computed without cancellation - real(wp) :: xi_M, xi_P - real(wp) :: xi_MP, xi_PP - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: R0_L, R0_R - real(wp), dimension(3) :: V0_L, V0_R - real(wp), dimension(3) :: P0_L, P0_R - real(wp), dimension(3) :: pbw_L, pbw_R - #:else - real(wp), dimension(nb) :: R0_L, R0_R - real(wp), dimension(nb) :: V0_L, V0_R - real(wp), dimension(nb) :: P0_L, P0_R - real(wp), dimension(nb) :: pbw_L, pbw_R - #:endif - - real(wp) :: alpha_L_sum, alpha_R_sum, nbub_L, nbub_R - real(wp) :: ptilde_L, ptilde_R - real(wp) :: PbwR3Lbar, PbwR3Rbar - real(wp) :: R3Lbar, R3Rbar - real(wp) :: R3V2Lbar, R3V2Rbar - real(wp), dimension(6) :: tau_e_L, tau_e_R - #:if not MFC_CASE_OPTIMIZATION and USING_AMD - real(wp), dimension(3) :: xi_field_L, xi_field_R - #:else - real(wp), dimension(num_dims) :: xi_field_L, xi_field_R - #:endif - real(wp) :: G_L, G_R - real(wp) :: vel_L_rms, vel_R_rms, vel_avg_rms - real(wp) :: vel_L_tmp, vel_R_tmp - real(wp) :: rho_Star, E_Star, p_Star, p_K_Star, vel_K_star - real(wp) :: pres_SL, pres_SR, Ms_L, Ms_R - real(wp) :: flux_ene_e - real(wp) :: zcoef, pcorr !< low Mach number correction - integer :: Re_max, 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, dqL_prim_dx_vf, dqL_prim_dy_vf, dqL_prim_dz_vf, & - & qR_prim_rsx_vf, dqR_prim_dx_vf, dqR_prim_dy_vf, dqR_prim_dz_vf, norm_dir, ix, iy, iz) - - ! Reshaping inputted data based on dimensional splitting direction - - call s_initialize_riemann_solver(flux_src_vf, norm_dir) - - #:for NORM_DIR, XYZ, STENCIL_VAR, COORDS, X_BND, Y_BND, Z_BND in & - [(1, 'x', 'j', '{STENCIL_IDX}, k, l', 'is1', 'is2', 'is3'), & - (2, 'y', 'k', 'j, {STENCIL_IDX}, l', 'is2', 'is1', 'is3'), & - (3, 'z', 'l', 'j, k, {STENCIL_IDX}', 'is3', 'is2', 'is1')] - #:set SV = STENCIL_VAR - #:set SF = lambda offs: COORDS.format(STENCIL_IDX = SV + offs) - if (norm_dir == ${NORM_DIR}$) then - ! 6-EQUATION MODEL WITH HLLC HLLC star-state flux with contact wave speed s_S - if (model_eqns == model_eqns_6eq) then - ! 6-equation model (model_eqns=3): separate phasic internal energies - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, j, k, l, q, vel_L, vel_R, Re_L, Re_R, alpha_L, alpha_R, Ys_L, & - & Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, Yi_avg, Phi_avg, h_iL, h_iR, & - & h_avg_2, tau_e_L, tau_e_R, flux_ene_e, xi_field_L, xi_field_R, pcorr, zcoef, rho_L, & - & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, T_avg, eps, c_sum_Yi_Phi, & - & T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & - & Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, G_L, G_R, & - & rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & - & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & - & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & - & xi_M, xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp - gamma_L = 0._wp; gamma_R = 0._wp - pi_inf_L = 0._wp; pi_inf_R = 0._wp - qv_L = 0._wp; qv_R = 0._wp - alpha_L_sum = 0._wp; alpha_R_sum = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - rho_L = 0._wp - gamma_L = 0._wp - pi_inf_L = 0._wp - qv_L = 0._wp - - rho_R = 0._wp - gamma_R = 0._wp - pi_inf_R = 0._wp - qv_R = 0._wp - - alpha_L_sum = 0._wp - alpha_R_sum = 0._wp - - if (mpp_lim) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - qL_prim_rsx_vf(${SF('')}$, i) = max(0._wp, qL_prim_rsx_vf(${SF('')}$, i)) - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = min(max(0._wp, qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%E + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - qR_prim_rsx_vf(${SF(' + 1')}$, i) = max(0._wp, qR_prim_rsx_vf(${SF(' + 1')}$, i)) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = min(max(0._wp, & - & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)), 1._wp) - alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%E + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = qR_prim_rsx_vf(${SF(' + 1')}$, & - & eqn_idx%E + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) - gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) - - rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) - gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) - - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%adv%beg + i - 1) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%adv%beg + i - 1) - end do - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + Re_idx(i, q))/Res_gs(i, q) + Re_L(i) - Re_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + Re_idx(i, q))/Res_gs(i, & - & q) + Re_R(i) - end do - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms + qv_R - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - end do - G_L = 0._wp; G_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - ! Hyperelastic stress contribution: strain energy added to total energy - if (hyperelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - xi_field_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%beg - 1 + i) - xi_field_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%beg - 1 + i) - end do - G_L = 0._wp; G_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%end + 1) - E_R = E_R + G_R*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%end + 1) - end if - $:GPU_LOOP(parallelism='[seq]') - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - end do - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & - & c_L, qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & - & c_R, qv_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & - & 0._wp, c_avg, qv_avg) - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - ! COMPUTING THE DIRECT WAVE SPEEDS - if (wave_speeds == wave_speeds_direct) then - if (elasticity) then - ! Elastic wave speed, Rodriguez et al. JCP (2019) - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & - & + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & - & ))/rho_R), & - & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & - & + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & - & + rho_L*vel_L(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)))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & - & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - end if - else if (wave_speeds == wave_speeds_pressure) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - ! Low Mach correction: Thornber et al. JCP (2008) - Ms_L = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & - & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & - & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - ! 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)))/min(s_L - s_S, -sgm_eps) - xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) - xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - - ! goes with numerical star velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5.e-1_wp + sign(0.5_wp, s_S)) - xi_P = (5.e-1_wp - sign(0.5_wp, s_S)) - - ! goes with the numerical velocity in x/y/z directions xi_P/M (pressure) = min/max(0. sgn(1,sL/sR)) - xi_MP = -min(0._wp, sign(1._wp, s_L)) - xi_PP = max(0._wp, sign(1._wp, s_R)) - - E_star = xi_M*(E_L + xi_MP*(xi_L*(E_L + (s_S - vel_L(dir_idx(1)))*(rho_L*s_S + pres_L/(s_L & - & - vel_L(dir_idx(1))))) - E_L)) + xi_P*(E_R + xi_PP*(xi_R*(E_R + (s_S & - & - vel_R(dir_idx(1)))*(rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1))))) - E_R)) - p_Star = xi_M*(pres_L + xi_MP*(rho_L*(s_L - vel_L(dir_idx(1)))*(s_S - vel_L(dir_idx(1))))) & - & + xi_P*(pres_R + xi_PP*(rho_R*(s_R - vel_R(dir_idx(1)))*(s_S - vel_R(dir_idx(1))))) - - rho_Star = xi_M*(rho_L*(xi_MP*xi_L + 1._wp - xi_MP)) + xi_P*(rho_R*(xi_PP*xi_R + 1._wp - xi_PP)) - - vel_K_Star = vel_L(dir_idx(1))*(1._wp - xi_MP) + xi_MP*vel_R(dir_idx(1)) + xi_MP*xi_PP*(s_S & - & - vel_R(dir_idx(1))) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING FLUXES MASS FLUX. - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! MOMENTUM FLUX. f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = rho_Star*vel_K_Star*(dir_flg(dir_idx(i)) & - & *vel_K_Star + (1._wp - dir_flg(dir_idx(i)))*(xi_M*vel_L(dir_idx(i)) & - & + xi_P*vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*p_Star + (s_M/s_L)*(s_P/s_R) & - & *dir_flg(dir_idx(i))*pcorr - end do - - ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - flux_rsx_vf(${SF('')}$, eqn_idx%E) = (E_star + p_Star)*vel_K_Star + (s_M/s_L)*(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - ! MOMENTUM ELASTIC FLUX. - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & - & - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - xi_M*(vel_L(dir_idx(i))*tau_e_L(dir_idx_tau(i)) & - & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i)) & - & /(s_L - vel_L(i)))))) - xi_P*(vel_R(dir_idx(i)) & - & *tau_e_R(dir_idx_tau(i)) + s_P*(xi_R*((s_S - vel_R(i)) & - & *(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rsx_vf(${SF('')}$, eqn_idx%E) = flux_rsx_vf(${SF('')}$, eqn_idx%E) + flux_ene_e - end if - - ! VOLUME FRACTION FLUX. - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*s_S + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, i)*s_S - end do - - ! Advection velocity source: interface velocity for volume fraction transport - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_src_rsx_vf(${SF('')}$, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i)) & - & *(s_S*(xi_MP*xi_L_m1 + 1) - vel_L(dir_idx(i)))) + xi_P*(vel_R(dir_idx(i)) & - & + dir_flg(dir_idx(i))*(s_S*(xi_PP*xi_R_m1 + 1) - vel_R(dir_idx(i)))) - end do - - ! INTERNAL ENERGIES ADVECTION FLUX. K-th pressure and velocity in preparation for the internal - ! energy flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - p_K_Star = xi_M*(xi_MP*((pres_L + pi_infs(i)/(1._wp + gammas(i)))*xi_L**(1._wp/gammas(i) & - & + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_L) + pres_L) & - & + xi_P*(xi_PP*((pres_R + pi_infs(i)/(1._wp + gammas(i))) & - & *xi_R**(1._wp/gammas(i) + 1._wp) - pi_infs(i)/(1._wp + gammas(i)) - pres_R) & - & + pres_R) - - flux_rsx_vf(${SF('')}$, i + eqn_idx%int_en%beg - 1) = ((xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i + eqn_idx%adv%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i + eqn_idx%adv%beg - 1))*(gammas(i)*p_K_Star + pi_infs(i)) & - & + (xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i + eqn_idx%cont%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i + eqn_idx%cont%beg - 1))*qvs(i))*vel_K_Star + (s_M/s_L)*(s_P/s_R) & - & *pcorr*s_S*(xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i + eqn_idx%adv%beg - 1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i + eqn_idx%adv%beg - 1)) - end do - - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%stress%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + xi_P*(s_S/(s_R - s_S)) & - & *(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - end do - end if - - ! Hyperelastic reference map flux for material deformation tracking - if (hyperelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%xi%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(dir_idx(1))*xi_field_L(i)) + xi_P*(s_S/(s_R - s_S)) & - & *(s_R*rho_R*xi_field_R(i) - rho_R*vel_R(dir_idx(1))*xi_field_R(i)) - end do - end if - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rsx_vf(${SF('')}$, eqn_idx%c) = (xi_M*qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%c) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%c))*s_S - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%int_en%beg, eqn_idx%int_en%end - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg - 1 + dir_idx(1)) = flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg - 1 + dir_idx(1)) - p_Star - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, sys_size - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg - 1 + dir_idx(1)) = flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg - 1 + dir_idx(1)) - p_Star - - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - else if (model_eqns == model_eqns_4eq) then - ! 4-equation model (model_eqns=4): single pressure, velocity equilibrium - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, alpha_rho_L, alpha_rho_R, vel_L, vel_R, alpha_L, alpha_R, & - & nbub_L, nbub_R, rho_L, rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, Cp_avg, Cv_avg, & - & T_avg, eps, c_sum_Yi_Phi, T_L, T_R, Y_L, Y_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, & - & Gamm_L, Gamm_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, qv_R, qv_avg, c_L, c_R, & - & G_L, G_R, rho_avg, H_avg, c_avg, gamma_avg, ptilde_L, ptilde_R, vel_L_rms, vel_R_rms, & - & vel_avg_rms, vel_L_tmp, vel_R_tmp, Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, & - & alpha_R_sum, rho_Star, E_Star, p_Star, p_K_Star, vel_K_star, s_L, s_R, s_M, s_P, s_S, & - & xi_M, xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP, Ys_L, Ys_R, Cp_iL, Cp_iR, Xs_L, & - & Xs_R, Gamma_iL, Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp - gamma_L = 0._wp; gamma_R = 0._wp - pi_inf_L = 0._wp; pi_inf_R = 0._wp - qv_L = 0._wp; qv_R = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - alpha_rho_L(i) = qL_prim_rsx_vf(${SF('')}$, i) - alpha_rho_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + alpha_rho_L(i) - gamma_L = gamma_L + alpha_L(i)*gammas(i) - pi_inf_L = pi_inf_L + alpha_L(i)*pi_infs(i) - qv_L = qv_L + alpha_rho_L(i)*qvs(i) - - rho_R = rho_R + alpha_rho_R(i) - gamma_R = gamma_R + alpha_R(i)*gammas(i) - pi_inf_R = pi_inf_R + alpha_R(i)*pi_infs(i) - qv_R = qv_R + alpha_rho_R(i)*qvs(i) - end do - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & - & c_L, qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & - & c_R, qv_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & - & 0._wp, c_avg, qv_avg) - - if (wave_speeds == wave_speeds_direct) 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)))) - else if (wave_speeds == wave_speeds_pressure) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - ! Low Mach correction: Thornber et al. JCP (2008) - Ms_L = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & - & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & - & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - ! 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)))/min(s_L - s_S, -sgm_eps) - xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) - xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - - ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) - xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, & - & i) = xi_M*alpha_rho_L(i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*alpha_rho_R(i) & - & *(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! Momentum flux. f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & - & ) + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_L) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*pres_R) - end do - - if (bubbles_euler) then - ! Put p_tilde in - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) + xi_M*(dir_flg(dir_idx(i))*(-1._wp*ptilde_L) & - & ) + xi_P*(dir_flg(dir_idx(i))*(-1._wp*ptilde_R)) - end do - end if - - flux_rsx_vf(${SF('')}$, eqn_idx%E) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%alf, eqn_idx%alf ! only advect the void fraction - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! Advection velocity source: interface velocity for volume fraction transport - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_src_rsx_vf(${SF('')}$, dir_idx(i)) = 0._wp - ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp - end do - - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) - - ! Add advection flux for bubble variables - if (bubbles_euler) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%bub%beg, eqn_idx%bub%end - flux_rsx_vf(${SF('')}$, i) = xi_M*nbub_L*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*nbub_R*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - end if - - ! Geometrical source flux for cylindrical coordinates - - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, sys_size - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & - & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - else if (model_eqns == model_eqns_5eq .and. bubbles_euler) then - ! 5-equation model with Euler-Euler bubble dynamics - $:GPU_PARALLEL_LOOP(collapse=3, private='[i, q, R0_L, R0_R, V0_L, V0_R, P0_L, P0_R, pbw_L, pbw_R, vel_L, & - & vel_R, rho_avg, alpha_L, alpha_R, h_avg, gamma_avg, Re_L, Re_R, pcorr, zcoef, rho_L, & - & rho_R, pres_L, pres_R, E_L, E_R, H_L, H_R, gamma_L, gamma_R, pi_inf_L, pi_inf_R, qv_L, & - & qv_R, qv_avg, c_L, c_R, c_avg, vel_L_rms, vel_R_rms, vel_avg_rms, vel_L_tmp, vel_R_tmp, & - & Ms_L, Ms_R, pres_SL, pres_SR, alpha_L_sum, alpha_R_sum, s_L, s_R, s_M, s_P, s_S, xi_M, & - & xi_P, xi_L, xi_R, xi_L_m1, xi_R_m1, xi_MP, xi_PP, nbub_L, nbub_R, PbwR3Lbar, PbwR3Rbar, & - & R3Lbar, R3Rbar, R3V2Lbar, R3V2Rbar, Ys_L, Ys_R, Cp_iL, Cp_iR, Xs_L, Xs_R, Gamma_iL, & - & Gamma_iR, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp - gamma_L = 0._wp; gamma_R = 0._wp - pi_inf_L = 0._wp; pi_inf_R = 0._wp - qv_L = 0._wp; qv_R = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - vel_L_rms = 0._wp; vel_R_rms = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - ! Retain this in the refactor - if (mpp_lim .and. (num_fluids > 2)) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) - gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) - rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) - gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) - end do - else if (num_fluids > 2) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - 1 - rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) - gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) - rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) - gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) - end do - else - rho_L = qL_prim_rsx_vf(${SF('')}$, 1) - gamma_L = gammas(1) - pi_inf_L = pi_infs(1) - qv_L = qvs(1) - rho_R = qR_prim_rsx_vf(${SF(' + 1')}$, 1) - gamma_R = gammas(1) - pi_inf_R = pi_infs(1) - qv_R = qvs(1) - end if - - if (viscous) then - if (num_fluids == 1) then ! Need to consider case with num_fluids >= 2 - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_L(i) = dflt_real - Re_R(i) = dflt_real - - if (Re_size(i) > 0) Re_L(i) = 0._wp - if (Re_size(i) > 0) Re_R(i) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = (1._wp - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + Re_idx(i, & - & q)))/Res_gs(i, q) + Re_L(i) - Re_R(i) = (1._wp - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + Re_idx(i, & - & q)))/Res_gs(i, q) + Re_R(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - end if - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1_wp*rho_L*vel_L_rms - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1_wp*rho_R*vel_R_rms - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - if (avg_state == avg_state_arithmetic) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, nb - R0_L(i) = qL_prim_rsx_vf(${SF('')}$, rs(i)) - R0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, rs(i)) - - V0_L(i) = qL_prim_rsx_vf(${SF('')}$, vs(i)) - V0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, vs(i)) - if (.not. polytropic .and. .not. qbmm) then - P0_L(i) = qL_prim_rsx_vf(${SF('')}$, ps(i)) - P0_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, ps(i)) - end if - end do - - if (.not. qbmm) then - if (adv_n) then - nbub_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%n) - nbub_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%n) - else - nbub_L = 0._wp - nbub_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, nb - nbub_L = nbub_L + (R0_L(i)**3._wp)*weight(i) - nbub_R = nbub_R + (R0_R(i)**3._wp)*weight(i) - end do - - nbub_L = (3._wp/(4._wp*pi))*qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + num_fluids)/nbub_L - nbub_R = (3._wp/(4._wp*pi))*qR_prim_rsx_vf(${SF(' + 1')}$, & - & eqn_idx%E + num_fluids)/nbub_R - end if - else - ! nb stored in 0th moment of first R0 bin in variable conversion module - nbub_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%bub%beg) - nbub_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%bub%beg) - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, nb - if (.not. qbmm) then - 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 do - - if (qbmm) then - PbwR3Lbar = mom_sp_rsx_vf(${SF('')}$, 4) - PbwR3Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 4) - - R3Lbar = mom_sp_rsx_vf(${SF('')}$, 1) - R3Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 1) - - R3V2Lbar = mom_sp_rsx_vf(${SF('')}$, 3) - R3V2Rbar = mom_sp_rsx_vf(${SF(' + 1')}$, 3) - else - PbwR3Lbar = 0._wp - PbwR3Rbar = 0._wp - - R3Lbar = 0._wp - R3Rbar = 0._wp - - R3V2Lbar = 0._wp - R3V2Rbar = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, nb - PbwR3Lbar = PbwR3Lbar + pbw_L(i)*(R0_L(i)**3._wp)*weight(i) - PbwR3Rbar = PbwR3Rbar + pbw_R(i)*(R0_R(i)**3._wp)*weight(i) - - R3Lbar = R3Lbar + (R0_L(i)**3._wp)*weight(i) - R3Rbar = R3Rbar + (R0_R(i)**3._wp)*weight(i) - - R3V2Lbar = R3V2Lbar + (R0_L(i)**3._wp)*(V0_L(i)**2._wp)*weight(i) - R3V2Rbar = R3V2Rbar + (R0_R(i)**3._wp)*(V0_R(i)**2._wp)*weight(i) - end do - end if - - rho_avg = 5.e-1_wp*(rho_L + rho_R) - H_avg = 5.e-1_wp*(H_L + H_R) - gamma_avg = 5.e-1_wp*(gamma_L + gamma_R) - qv_avg = 5.e-1_wp*(qv_L + qv_R) - vel_avg_rms = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_avg_rms = vel_avg_rms + (5.e-1_wp*(vel_L(i) + vel_R(i)))**2._wp - end do - end if - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & - & c_L, qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & - & c_R, qv_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & - & 0._wp, c_avg, qv_avg) - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - if (wave_speeds == wave_speeds_direct) 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)))) - else if (wave_speeds == wave_speeds_pressure) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - ! Low Mach correction: Thornber et al. JCP (2008) - Ms_L = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & - & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & - & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - ! 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)))/min(s_L - s_S, -sgm_eps) - xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) - xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - - ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) - xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - if (bubbles_euler .and. (num_fluids > 1)) then - ! Kill mass transport @ gas density - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end) = 0._wp - end if - - ! Momentum flux. f = \rho u u + p I, q = \rho u, q_star = \xi * \rho*(s_star, v, w) - - ! Include p_tilde - - if (avg_state == avg_state_arithmetic) then - if (alpha_L(num_fluids) < small_alf .or. R3Lbar < small_alf) then - pres_L = pres_L - alpha_L(num_fluids)*pres_L - else - pres_L = pres_L - alpha_L(num_fluids)*(pres_L - PbwR3Lbar/R3Lbar - rho_L*R3V2Lbar/R3Lbar) - end if - - if (alpha_R(num_fluids) < small_alf .or. R3Rbar < small_alf) then - pres_R = pres_R - alpha_R(num_fluids)*pres_R - else - pres_R = pres_R - alpha_R(num_fluids)*(pres_R - PbwR3Rbar/R3Rbar - rho_R*R3V2Rbar/R3Rbar) - end if - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & - & ) + s_M*(xi_L*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i))) - vel_L(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_L)) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) & - & + s_P*(xi_R*(dir_flg(dir_idx(i))*s_S + (1._wp - dir_flg(dir_idx(i))) & - & *vel_R(dir_idx(i))) - vel_R(dir_idx(i)))) + dir_flg(dir_idx(i))*(pres_R)) & - & + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr - end do - - ! Energy flux. f = u*(E+p), q = E, q_star = \xi*E+(s-u)(\rho s_star + p/(s-u)) - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + s_M*(xi_L*(E_L + (s_S & - & - vel_L(dir_idx(1)))*(rho_L*s_S + (pres_L)/(s_L - vel_L(dir_idx(1))))) - E_L)) & - & + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R) + s_P*(xi_R*(E_R + (s_S - vel_R(dir_idx(1)) & - & )*(rho_R*s_S + (pres_R)/(s_R - vel_R(dir_idx(1))))) - E_R)) + (s_M/s_L)*(s_P/s_R) & - & *pcorr*s_S - - ! Volume fraction flux - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! Advection velocity source: interface velocity for volume fraction transport - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_src_rsx_vf(${SF('')}$, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*xi_L_m1) & - & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*xi_R_m1) - - ! IF ( (model_eqns == 4) .or. (num_fluids==1) ) vel_src_rs_vf(dir_idx(i))%sf(j,k,l) = 0._wp - end do - - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) - - ! Add advection flux for bubble variables - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%bub%beg, eqn_idx%bub%end - flux_rsx_vf(${SF('')}$, i) = xi_M*nbub_L*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*nbub_R*qR_prim_rsx_vf(${SF(' + 1')}$, i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - if (qbmm) then - flux_rsx_vf(${SF('')}$, & - & eqn_idx%bub%beg) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end if - - if (adv_n) then - flux_rsx_vf(${SF('')}$, & - & eqn_idx%n) = xi_M*nbub_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*nbub_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, sys_size - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & - & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - else - ! 5-equation model (model_eqns=2): mixture total energy, volume fraction advection - $:GPU_PARALLEL_LOOP(collapse=3, private='[Re_max, i, q, T_L, T_R, vel_L_rms, vel_R_rms, pres_L, pres_R, & - & rho_L, gamma_L, pi_inf_L, qv_L, rho_R, gamma_R, pi_inf_R, qv_R, alpha_L_sum, & - & alpha_R_sum, E_L, E_R, MW_L, MW_R, R_gas_L, R_gas_R, Cp_L, Cp_R, Cv_L, Cv_R, Gamm_L, & - & Gamm_R, Y_L, Y_R, H_L, H_R, qv_avg, rho_avg, gamma_avg, H_avg, c_L, c_R, c_avg, s_P, & - & s_M, xi_P, xi_M, xi_L, xi_R, xi_L_m1, xi_R_m1, Ms_L, Ms_R, pres_SL, pres_SR, vel_L, & - & vel_R, Re_L, Re_R, alpha_L, alpha_R, s_L, s_R, s_S, vel_avg_rms, pcorr, zcoef, & - & vel_L_tmp, vel_R_tmp, Ys_L, Ys_R, Xs_L, Xs_R, Gamma_iL, Gamma_iR, Cp_iL, Cp_iR, & - & tau_e_L, tau_e_R, xi_field_L, xi_field_R, Yi_avg, Phi_avg, h_iL, h_iR, h_avg_2, G_L, & - & G_R]', copyin='[is1, is2, is3]') - do l = ${Z_BND}$%beg, ${Z_BND}$%end - do k = ${Y_BND}$%beg, ${Y_BND}$%end - do j = ${X_BND}$%beg, ${X_BND}$%end - vel_L_rms = 0._wp; vel_R_rms = 0._wp - rho_L = 0._wp; rho_R = 0._wp - gamma_L = 0._wp; gamma_R = 0._wp - pi_inf_L = 0._wp; pi_inf_R = 0._wp - qv_L = 0._wp; qv_R = 0._wp - alpha_L_sum = 0._wp; alpha_R_sum = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - alpha_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%cont%end + i) - vel_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%cont%end + i) - vel_L_rms = vel_L_rms + vel_L(i)**2._wp - vel_R_rms = vel_R_rms + vel_R(i)**2._wp - end do - - pres_L = qL_prim_rsx_vf(${SF('')}$, eqn_idx%E) - pres_R = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E) - - ! Change this by splitting it into the cases present in the bubbles_euler - if (mpp_lim) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - qL_prim_rsx_vf(${SF('')}$, i) = max(0._wp, qL_prim_rsx_vf(${SF('')}$, i)) - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = min(max(0._wp, qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%E + i)), 1._wp) - qR_prim_rsx_vf(${SF(' + 1')}$, i) = max(0._wp, qR_prim_rsx_vf(${SF(' + 1')}$, i)) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = min(max(0._wp, & - & qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)), 1._wp) - alpha_L_sum = alpha_L_sum + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) - alpha_R_sum = alpha_R_sum + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) - end do - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i) = qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%E + i)/max(alpha_L_sum, sgm_eps) - qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i) = qR_prim_rsx_vf(${SF(' + 1')}$, & - & eqn_idx%E + i)/max(alpha_R_sum, sgm_eps) - end do - end if - - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - rho_L = rho_L + qL_prim_rsx_vf(${SF('')}$, i) - gamma_L = gamma_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*gammas(i) - pi_inf_L = pi_inf_L + qL_prim_rsx_vf(${SF('')}$, eqn_idx%E + i)*pi_infs(i) - qv_L = qv_L + qL_prim_rsx_vf(${SF('')}$, i)*qvs(i) - - rho_R = rho_R + qR_prim_rsx_vf(${SF(' + 1')}$, i) - gamma_R = gamma_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*gammas(i) - pi_inf_R = pi_inf_R + qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%E + i)*pi_infs(i) - qv_R = qv_R + qR_prim_rsx_vf(${SF(' + 1')}$, i)*qvs(i) - end do - - Re_max = 0 - if (Re_size(1) > 0) Re_max = 1 - if (Re_size(2) > 0) Re_max = 2 - - if (viscous) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, Re_max - Re_L(i) = 0._wp - Re_R(i) = 0._wp - - $:GPU_LOOP(parallelism='[seq]') - do q = 1, Re_size(i) - Re_L(i) = alpha_L(Re_idx(i, q))/Res_gs(i, q) + Re_L(i) - Re_R(i) = alpha_R(Re_idx(i, q))/Res_gs(i, q) + Re_R(i) - end do - - Re_L(i) = 1._wp/max(Re_L(i), sgm_eps) - Re_R(i) = 1._wp/max(Re_R(i), sgm_eps) - end do - end if - - if (chemistry) then - c_sum_Yi_Phi = 0.0_wp - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Ys_L(i - eqn_idx%species%beg + 1) = qL_prim_rsx_vf(${SF('')}$, i) - Ys_R(i - eqn_idx%species%beg + 1) = qR_prim_rsx_vf(${SF(' + 1')}$, i) - end do - - call get_mixture_molecular_weight(Ys_L, MW_L) - call get_mixture_molecular_weight(Ys_R, MW_R) - - Xs_L(:) = Ys_L(:)*MW_L/molecular_weights(:) - Xs_R(:) = Ys_R(:)*MW_R/molecular_weights(:) - - R_gas_L = gas_constant/MW_L - R_gas_R = gas_constant/MW_R - - T_L = pres_L/rho_L/R_gas_L - T_R = pres_R/rho_R/R_gas_R - - call get_species_specific_heats_r(T_L, Cp_iL) - call get_species_specific_heats_r(T_R, Cp_iR) - - if (chem_params%gamma_method == 1) then - !> gamma_method = 1: Ref. Section 2.3.1 Formulation of doi:10.7907/ZKW8-ES97. - Gamma_iL = Cp_iL/(Cp_iL - 1.0_wp) - Gamma_iR = Cp_iR/(Cp_iR - 1.0_wp) - - gamma_L = sum(Xs_L(:)/(Gamma_iL(:) - 1.0_wp)) - gamma_R = sum(Xs_R(:)/(Gamma_iR(:) - 1.0_wp)) - else if (chem_params%gamma_method == 2) then - !> gamma_method = 2: c_p / c_v where c_p, c_v are specific heats. - call get_mixture_specific_heat_cp_mass(T_L, Ys_L, Cp_L) - call get_mixture_specific_heat_cp_mass(T_R, Ys_R, Cp_R) - call get_mixture_specific_heat_cv_mass(T_L, Ys_L, Cv_L) - call get_mixture_specific_heat_cv_mass(T_R, Ys_R, Cv_R) - - Gamm_L = Cp_L/Cv_L; Gamm_R = Cp_R/Cv_R - gamma_L = 1.0_wp/(Gamm_L - 1.0_wp); gamma_R = 1.0_wp/(Gamm_R - 1.0_wp) - end if - - call get_mixture_energy_mass(T_L, Ys_L, E_L) - call get_mixture_energy_mass(T_R, Ys_R, E_R) - - E_L = rho_L*E_L + 5.e-1*rho_L*vel_L_rms - E_R = rho_R*E_R + 5.e-1*rho_R*vel_R_rms - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - else - E_L = gamma_L*pres_L + pi_inf_L + 5.e-1*rho_L*vel_L_rms + qv_L - E_R = gamma_R*pres_R + pi_inf_R + 5.e-1*rho_R*vel_R_rms + qv_R - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - end if - - ! ENERGY ADJUSTMENTS FOR HYPOELASTIC ENERGY - if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - end do - G_L = 0._wp - G_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - ! Elastic contribution to energy if G large enough - if ((G_L > verysmall) .and. (G_R > verysmall)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - ! Additional terms in 2D and 3D - if ((i == 2) .or. (i == 4) .or. (i == 5)) then - E_L = E_L + (tau_e_L(i)*tau_e_L(i))/(4._wp*G_L) - E_R = E_R + (tau_e_R(i)*tau_e_R(i))/(4._wp*G_R) - end if - end if - end do - end if - - ! Hyperelastic stress contribution: strain energy added to total energy - if (hyperelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - xi_field_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%beg - 1 + i) - xi_field_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%beg - 1 + i) - end do - G_L = 0._wp - G_R = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_fluids - ! Mixture left and right shear modulus - G_L = G_L + alpha_L(i)*Gs_rs(i) - G_R = G_R + alpha_R(i)*Gs_rs(i) - end do - ! Elastic contribution to energy if G large enough - if (G_L > verysmall .and. G_R > verysmall) then - E_L = E_L + G_L*qL_prim_rsx_vf(${SF('')}$, eqn_idx%xi%end + 1) - E_R = E_R + G_R*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%xi%end + 1) - end if - $:GPU_LOOP(parallelism='[seq]') - do i = 1, b_size - 1 - tau_e_L(i) = qL_prim_rsx_vf(${SF('')}$, eqn_idx%stress%beg - 1 + i) - tau_e_R(i) = qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%stress%beg - 1 + i) - end do - end if - - H_L = (E_L + pres_L)/rho_L - H_R = (E_R + pres_R)/rho_R - - @:compute_average_state() - - call s_compute_speed_of_sound(pres_L, rho_L, gamma_L, pi_inf_L, H_L, alpha_L, vel_L_rms, 0._wp, & - & c_L, qv_L) - - call s_compute_speed_of_sound(pres_R, rho_R, gamma_R, pi_inf_R, H_R, alpha_R, vel_R_rms, 0._wp, & - & c_R, qv_R) - - !> The computation of c_avg does not require all the variables, and therefore the non '_avg' - ! variables are placeholders to call the subroutine. - call s_compute_speed_of_sound(pres_R, rho_avg, gamma_avg, pi_inf_R, H_avg, alpha_R, vel_avg_rms, & - & c_sum_Yi_Phi, c_avg, qv_avg) - - if (viscous) then - if (chemistry) then - call compute_viscosity_and_inversion(T_L, Ys_L, T_R, Ys_R, Re_L(1), Re_R(1)) - end if - $:GPU_LOOP(parallelism='[seq]') - do i = 1, 2 - Re_avg_rsx_vf(${SF('')}$, i) = 2._wp/(1._wp/Re_L(i) + 1._wp/Re_R(i)) - end do - end if - - ! Low Mach correction - if (low_Mach == 2) then - @:compute_low_Mach_correction() - end if - - if (wave_speeds == wave_speeds_direct) then - if (elasticity) then - ! Elastic wave speed, Rodriguez et al. JCP (2019) - s_L = min(vel_L(dir_idx(1)) - sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) + tau_e_L(dir_idx_tau(1) & - & ))/rho_L), & - & vel_R(dir_idx(1)) - sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) & - & + tau_e_R(dir_idx_tau(1)))/rho_R)) - s_R = max(vel_R(dir_idx(1)) + sqrt(c_R*c_R + (((4._wp*G_R)/3._wp) + tau_e_R(dir_idx_tau(1) & - & ))/rho_R), & - & vel_L(dir_idx(1)) + sqrt(c_L*c_L + (((4._wp*G_L)/3._wp) & - & + tau_e_L(dir_idx_tau(1)))/rho_L)) - s_S = (pres_R - tau_e_R(dir_idx_tau(1)) - pres_L + tau_e_L(dir_idx_tau(1)) & - & + rho_L*vel_L(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)))) - else - s_L = min(vel_L(dir_idx(1)) - c_L, vel_R(dir_idx(1)) - c_R) - s_R = max(vel_R(dir_idx(1)) + c_R, vel_L(dir_idx(1)) + c_L) - s_S = (pres_R - pres_L + rho_L*vel_L(dir_idx(1))*(s_L - vel_L(dir_idx(1))) & - & - rho_R*vel_R(dir_idx(1))*(s_R - vel_R(dir_idx(1))))/(rho_L*(s_L & - & - vel_L(dir_idx(1))) - rho_R*(s_R - vel_R(dir_idx(1)))) - end if - else if (wave_speeds == wave_speeds_pressure) then - pres_SL = 5.e-1_wp*(pres_L + pres_R + rho_avg*c_avg*(vel_L(dir_idx(1)) - vel_R(dir_idx(1)))) - - pres_SR = pres_SL - - ! Low Mach correction: Thornber et al. JCP (2008) - Ms_L = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_L)/(1._wp + gamma_L))*(pres_SL/pres_L - 1._wp) & - & *pres_L/((pres_L + pi_inf_L/(1._wp + gamma_L))))) - Ms_R = max(1._wp, & - & sqrt(1._wp + ((5.e-1_wp + gamma_R)/(1._wp + gamma_R))*(pres_SR/pres_R - 1._wp) & - & *pres_R/((pres_R + pi_inf_R/(1._wp + gamma_R))))) - - s_L = vel_L(dir_idx(1)) - c_L*Ms_L - s_R = vel_R(dir_idx(1)) + c_R*Ms_R - - s_S = 5.e-1_wp*((vel_L(dir_idx(1)) + vel_R(dir_idx(1))) + (pres_L - pres_R)/(rho_avg*c_avg)) - end if - - ! follows Einfeldt et al. s_M/P = min/max(0.,s_L/R) - s_M = min(0._wp, s_L); s_P = max(0._wp, s_R) - - ! 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)))/min(s_L - s_S, -sgm_eps) - xi_R = (s_R - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - ! xi_L/R - 1 = (s_S - u_L/R)/(s_L/R - s_star): avoids cancellation when xi \approx 1 - xi_L_m1 = (s_S - vel_L(dir_idx(1)))/min(s_L - s_S, -sgm_eps) - xi_R_m1 = (s_S - vel_R(dir_idx(1)))/max(s_R - s_S, sgm_eps) - - ! goes with numerical velocity in x/y/z directions xi_P/M = 0.5 +/m sgn(0.5,s_star) - xi_M = (5.e-1_wp + sign(5.e-1_wp, s_S)) - xi_P = (5.e-1_wp - sign(5.e-1_wp, s_S)) - - ! Low Mach correction - if (low_Mach == 1) then - @:compute_low_Mach_correction() - else - pcorr = 0._wp - end if - - ! COMPUTING THE HLLC FLUXES MASS FLUX. - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%cont%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! MOMENTUM FLUX. f = \rho u u - \sigma, q = \rho u, q_star = \xi * \rho*(s_star, v, w) identity: - ! xi*(dir_flg*s_S+(1-dir_flg)*u_i)-u_i = (dir_flg*s_L/R+(1-dir_flg)*u_i)*xi_m1 - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) = xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(i) & - & ) + s_M*(dir_flg(dir_idx(i))*s_L + (1._wp - dir_flg(dir_idx(i))) & - & *vel_L(dir_idx(i)))*xi_L_m1) + dir_flg(dir_idx(i))*(pres_L)) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(i)) + s_P*(dir_flg(dir_idx(i)) & - & *s_R + (1._wp - dir_flg(dir_idx(i)))*vel_R(dir_idx(i)))*xi_R_m1) & - & + dir_flg(dir_idx(i))*(pres_R)) + (s_M/s_L)*(s_P/s_R)*dir_flg(dir_idx(i))*pcorr - end do - - ! ENERGY FLUX. f = u*(E-\sigma), q = E, q_star = \xi*E+(s-u)(\rho s_star - \sigma/(s-u)) - ! xi*(E+expr)-E = E*xi_m1 + xi*expr avoids E*(xi-1) cancellation - flux_rsx_vf(${SF('')}$, & - & eqn_idx%E) = xi_M*(vel_L(dir_idx(1))*(E_L + pres_L) + s_M*(E_L*xi_L_m1 + xi_L*(s_S & - & - vel_L(dir_idx(1)))*(rho_L*s_S + pres_L/(s_L - vel_L(dir_idx(1)))))) & - & + xi_P*(vel_R(dir_idx(1))*(E_R + pres_R) + s_P*(E_R*xi_R_m1 + xi_R*(s_S & - & - vel_R(dir_idx(1)))*(rho_R*s_S + pres_R/(s_R - vel_R(dir_idx(1)))))) + (s_M/s_L) & - & *(s_P/s_R)*pcorr*s_S - - ! ELASTICITY. Elastic shear stress additions for the momentum and energy flux - if (elasticity) then - flux_ene_e = 0._wp - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - ! MOMENTUM ELASTIC FLUX. - flux_rsx_vf(${SF('')}$, eqn_idx%cont%end + dir_idx(i)) = flux_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(i)) - xi_M*tau_e_L(dir_idx_tau(i)) & - & - xi_P*tau_e_R(dir_idx_tau(i)) - ! ENERGY ELASTIC FLUX. - flux_ene_e = flux_ene_e - xi_M*(vel_L(dir_idx(i))*tau_e_L(dir_idx_tau(i)) & - & + s_M*(xi_L*((s_S - vel_L(i))*(tau_e_L(dir_idx_tau(i)) & - & /(s_L - vel_L(i)))))) - xi_P*(vel_R(dir_idx(i)) & - & *tau_e_R(dir_idx_tau(i)) + s_P*(xi_R*((s_S - vel_R(i)) & - & *(tau_e_R(dir_idx_tau(i))/(s_R - vel_R(i)))))) - end do - flux_rsx_vf(${SF('')}$, eqn_idx%E) = flux_rsx_vf(${SF('')}$, eqn_idx%E) + flux_ene_e - end if - - ! HYPOELASTIC STRESS EVOLUTION FLUX. - if (hypoelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%stress%end - eqn_idx%stress%beg + 1 - flux_rsx_vf(${SF('')}$, & - & eqn_idx%stress%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*tau_e_L(i) & - & - rho_L*vel_L(dir_idx(1))*tau_e_L(i)) + xi_P*(s_S/(s_R - s_S)) & - & *(s_R*rho_R*tau_e_R(i) - rho_R*vel_R(dir_idx(1))*tau_e_R(i)) - end do - end if - - ! VOLUME FRACTION FLUX. - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_rsx_vf(${SF('')}$, i) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & i)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, & - & i)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end do - - ! VOLUME FRACTION SOURCE FLUX. - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - vel_src_rsx_vf(${SF('')}$, & - & dir_idx(i)) = xi_M*(vel_L(dir_idx(i)) + dir_flg(dir_idx(i))*s_M*xi_L_m1) & - & + xi_P*(vel_R(dir_idx(i)) + dir_flg(dir_idx(i))*s_P*xi_R_m1) - end do - - ! COLOR FUNCTION FLUX - if (surface_tension) then - flux_rsx_vf(${SF('')}$, eqn_idx%c) = xi_M*qL_prim_rsx_vf(${SF('')}$, & - & eqn_idx%c)*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*qR_prim_rsx_vf(${SF(' + 1')}$, eqn_idx%c)*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - end if - - ! Hyperelastic reference map flux for material deformation tracking - if (hyperelasticity) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, num_dims - flux_rsx_vf(${SF('')}$, & - & eqn_idx%xi%beg - 1 + i) = xi_M*(s_S/(s_L - s_S))*(s_L*rho_L*xi_field_L(i) & - & - rho_L*vel_L(dir_idx(1))*xi_field_L(i)) + xi_P*(s_S/(s_R - s_S)) & - & *(s_R*rho_R*xi_field_R(i) - rho_R*vel_R(dir_idx(1))*xi_field_R(i)) - end do - end if - - flux_src_rsx_vf(${SF('')}$, eqn_idx%adv%beg) = vel_src_rsx_vf(${SF('')}$, dir_idx(1)) - - if (chemistry) then - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%species%beg, eqn_idx%species%end - Y_L = qL_prim_rsx_vf(${SF('')}$, i) - Y_R = qR_prim_rsx_vf(${SF(' + 1')}$, i) - - flux_rsx_vf(${SF('')}$, & - & i) = xi_M*rho_L*Y_L*(vel_L(dir_idx(1)) + s_M*xi_L_m1) & - & + xi_P*rho_R*Y_R*(vel_R(dir_idx(1)) + s_P*xi_R_m1) - flux_src_rsx_vf(${SF('')}$, i) = 0.0_wp - end do - end if - - ! Geometrical source flux for cylindrical coordinates - #:if (NORM_DIR == 2) - if (cyl_coord) then - ! Substituting the advective flux into the inviscid geometrical source flux - $:GPU_LOOP(parallelism='[seq]') - do i = 1, eqn_idx%E - flux_gsrc_rsx_vf(${SF('')}$, i) = flux_rsx_vf(${SF('')}$, i) - end do - ! Recalculating the radial momentum geometric source flux - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%cont%end + dir_idx(1)) = xi_M*(rho_L*(vel_L(dir_idx(1)) & - & *vel_L(dir_idx(1)) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp & - & - dir_flg(dir_idx(1)))*vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & + xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - ! Geometrical source of the void fraction(s) is zero - $:GPU_LOOP(parallelism='[seq]') - do i = eqn_idx%adv%beg, eqn_idx%adv%end - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - end if - #:endif - #:if (NORM_DIR == 3) - if (grid_geometry == 3) then - $:GPU_LOOP(parallelism='[seq]') - do i = 1, sys_size - flux_gsrc_rsx_vf(${SF('')}$, i) = 0._wp - end do - - flux_gsrc_rsx_vf(${SF('')}$, & - & eqn_idx%mom%beg + 1) = -xi_M*(rho_L*(vel_L(dir_idx(1))*vel_L(dir_idx(1) & - & ) + s_M*(xi_L*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_L(dir_idx(1))) - vel_L(dir_idx(1))))) & - & - xi_P*(rho_R*(vel_R(dir_idx(1))*vel_R(dir_idx(1)) & - & + s_P*(xi_R*(dir_flg(dir_idx(1))*s_S + (1._wp - dir_flg(dir_idx(1))) & - & *vel_R(dir_idx(1))) - vel_R(dir_idx(1))))) - flux_gsrc_rsx_vf(${SF('')}$, eqn_idx%mom%end) = flux_rsx_vf(${SF('')}$, eqn_idx%mom%beg + 1) - end if - #:endif - end do - end do - end do - $:END_GPU_PARALLEL_LOOP() - end if - end if - #:endfor - ! Computing HLLC flux and source flux for Euler system of equations - - if (viscous) then - if (weno_Re_flux) then - call s_compute_viscous_source_flux(qL_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & qR_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & - & norm_dir, ix, iy, iz) - else - call s_compute_viscous_source_flux(q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqL_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & q_prim_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dx_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dy_vf(eqn_idx%mom%beg:eqn_idx%mom%end), & - & dqR_prim_dz_vf(eqn_idx%mom%beg:eqn_idx%mom%end), flux_src_vf, q_prim_vf, & - & norm_dir, ix, iy, iz) - end if - end if - - if (surface_tension) then - call s_compute_capillary_source_flux(vel_src_rsx_vf, flux_src_vf, norm_dir, isx, isy, isz) - end if - - call s_finalize_riemann_solver(flux_vf, flux_src_vf, flux_gsrc_vf, norm_dir) - - end subroutine s_hllc_riemann_solver - !> Initialize the Riemann solvers module impure subroutine s_initialize_riemann_solvers_module From 563f7764f35df1164e695c4d94b0722e5e2c856e Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 03:56:05 -0400 Subject: [PATCH 10/11] src: drop unused imports from the riemann dispatcher core Review follow-up: m_mpi_proxy and m_helper_basic are unreferenced in the slimmed core under all configs. --- src/simulation/m_riemann_solvers.fpp | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/simulation/m_riemann_solvers.fpp b/src/simulation/m_riemann_solvers.fpp index e3f00a69eb..467769dc0c 100644 --- a/src/simulation/m_riemann_solvers.fpp +++ b/src/simulation/m_riemann_solvers.fpp @@ -11,8 +11,6 @@ module m_riemann_solvers use m_derived_types use m_global_parameters - use m_mpi_proxy - use m_helper_basic use m_riemann_state use m_riemann_solver_hllc use m_riemann_solver_lf From adfea36727398a943157f190170ebb91dbb65bab Mon Sep 17 00:00:00 2001 From: Spencer Bryngelson Date: Thu, 11 Jun 2026 19:58:49 -0400 Subject: [PATCH 11/11] docs: correct the parameter-regeneration guidance in contributing Both passages predated the build-time generation command and still said reconfigure; a plain rebuild regenerates automatically (the command is ninja-tracked against toolchain/mfc/params/), and only adding a new file there needs a reconfigure. Flagged by Copilot review on #1556. --- docs/documentation/contributing.md | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/docs/documentation/contributing.md b/docs/documentation/contributing.md index 0468e01e2f..ad85b864a0 100644 --- a/docs/documentation/contributing.md +++ b/docs/documentation/contributing.md @@ -318,9 +318,9 @@ If your check enforces a physics constraint, also add a `PHYSICS_DOCS` entry (se Scalar declarations, GPU declare lines, Doxygen descriptions, and namelist bindings are auto-generated at build time (ninja-tracked custom command) from the `TYPED_DECLS` and `FORTRAN_ARRAY_DIMS` tables in `toolchain/mfc/params/definitions.py`. For a plain scalar registered with -`_r()` / `_nv()` above, no manual Fortran edit is needed — reconfigure (`./mfc.sh build`) -and the generated include in `m_global_parameters_common.fpp` (compiled per target) is updated -automatically. +`_r()` / `_nv()` above, no manual Fortran edit is needed — the next build regenerates the +include in `m_global_parameters_common.fpp` (compiled per target) automatically: the +generation command is ninja-tracked against every file under `toolchain/mfc/params/`. Still manual (not auto-generated): @@ -333,8 +333,9 @@ Still manual (not auto-generated): include) - `CASE_OPT_EXTRA_LINES` in `toolchain/mfc/params/generators/fortran_gen.py` for case-optimization constants -After editing any generator or table, force regen by reconfiguring (`./mfc.sh build`) — -cached builds compile stale includes. +Editing any existing file under `toolchain/mfc/params/` (tables or generators) triggers +regeneration on the next build automatically. Only *adding a new file* there requires one +reconfigure — the dependency list is globbed at configure time. **Step 6: Use in Fortran code**